projects / p5sagit/p5-mst-13.2.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | history | HEAD
Re: [PATCH lib/ExtUtils.t] Extra Files for QNX
[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;
98ea0861 345$warnLevel = 1 unless defined $warnLevel;
346$dieLevel = 1 unless defined $dieLevel;
4c82ae22 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++) {
1b4321cf 892 my ($stop,$action);
04e43a21 893 ($stop,$action) = split(/\0/, $dbline{$i}) if
894 $dbline{$i};
54d04a52 895 $arrow = ($i==$line
896 and $filename eq $filename_ini)
897 ? '==>'
36477c24 898 : ($dbline[$i]+0 ? ':' : ' ') ;
54d04a52 899 $arrow .= 'b' if $stop;
900 $arrow .= 'a' if $action;
901 print $OUT "$i$arrow\t", $dbline[$i];
65c9c81d 902 $i++, last if $signal;
d338d6fe 903 }
65c9c81d 904 print $OUT "\n" unless $dbline[$i-1] =~ /\n$/;
d338d6fe 905 }
906 $start = $i; # remember in case they want more
907 $start = $max if $start > $max;
908 next CMD; };
909 $cmd =~ /^D$/ && do {
55497cff 910 print $OUT "Deleting all breakpoints...\n";
911 my $file;
912 for $file (keys %had_breakpoints) {
8ebc5c01 913 local *dbline = $main::{'_<' . $file};
55497cff 914 my $max = $#dbline;
915 my $was;
916
d338d6fe 917 for ($i = 1; $i <= $max ; $i++) {
918 if (defined $dbline{$i}) {
919 $dbline{$i} =~ s/^[^\0]+//;
920 if ($dbline{$i} =~ s/^\0?$//) {
921 delete $dbline{$i};
922 }
923 }
924 }
3fbd6552 925
926 if (not $had_breakpoints{$file} &= ~1) {
927 delete $had_breakpoints{$file};
928 }
55497cff 929 }
930 undef %postponed;
931 undef %postponed_file;
932 undef %break_on_load;
55497cff 933 next CMD; };
d338d6fe 934 $cmd =~ /^L$/ && do {
55497cff 935 my $file;
936 for $file (keys %had_breakpoints) {
8ebc5c01 937 local *dbline = $main::{'_<' . $file};
55497cff 938 my $max = $#dbline;
939 my $was;
940
d338d6fe 941 for ($i = 1; $i <= $max; $i++) {
942 if (defined $dbline{$i}) {
2002527a 943 print $OUT "$file:\n" unless $was++;
55497cff 944 print $OUT " $i:\t", $dbline[$i];
d338d6fe 945 ($stop,$action) = split(/\0/, $dbline{$i});
55497cff 946 print $OUT " break if (", $stop, ")\n"
d338d6fe 947 if $stop;
55497cff 948 print $OUT " action: ", $action, "\n"
d338d6fe 949 if $action;
950 last if $signal;
951 }
952 }
55497cff 953 }
954 if (%postponed) {
955 print $OUT "Postponed breakpoints in subroutines:\n";
956 my $subname;
957 for $subname (keys %postponed) {
958 print $OUT " $subname\t$postponed{$subname}\n";
959 last if $signal;
960 }
961 }
962 my @have = map { # Combined keys
963 keys %{$postponed_file{$_}}
964 } keys %postponed_file;
965 if (@have) {
966 print $OUT "Postponed breakpoints in files:\n";
967 my ($file, $line);
968 for $file (keys %postponed_file) {
0c395bd7 969 my $db = $postponed_file{$file};
55497cff 970 print $OUT " $file:\n";
0c395bd7 971 for $line (sort {$a <=> $b} keys %$db) {
08a4aec0 972 print $OUT " $line:\n";
0c395bd7 973 my ($stop,$action) = split(/\0/, $$db{$line});
55497cff 974 print $OUT " break if (", $stop, ")\n"
975 if $stop;
976 print $OUT " action: ", $action, "\n"
977 if $action;
978 last if $signal;
979 }
980 last if $signal;
981 }
982 }
983 if (%break_on_load) {
984 print $OUT "Breakpoints on load:\n";
985 my $file;
986 for $file (keys %break_on_load) {
987 print $OUT " $file\n";
988 last if $signal;
989 }
990 }
6027b9a3 991 if ($trace & 2) {
992 print $OUT "Watch-expressions:\n";
993 my $expr;
994 for $expr (@to_watch) {
995 print $OUT " $expr\n";
996 last if $signal;
997 }
998 }
55497cff 999 next CMD; };
1000 $cmd =~ /^b\b\s*load\b\s*(.*)/ && do {
477ea2b1 1001 my $file = $1; $file =~ s/\s+$//;
f1583d8f 1002 cmd_b_load($file);
55497cff 1003 next CMD; };
1d06cb2d 1004 $cmd =~ /^b\b\s*(postpone|compile)\b\s*([':A-Za-z_][':\w]*)\s*(.*)/ && do {
a223bd61 1005 my $cond = length $3 ? $3 : '1';
1d06cb2d 1006 my ($subname, $break) = ($2, $1 eq 'postpone');
a223bd61 1007 $subname =~ s/\'/::/g;
55497cff 1008 $subname = "${'package'}::" . $subname
1009 unless $subname =~ /::/;
1010 $subname = "main".$subname if substr($subname,0,2) eq "::";
1d06cb2d 1011 $postponed{$subname} = $break
1012 ? "break +0 if $cond" : "compile";
d338d6fe 1013 next CMD; };
83ee9e09 1014 $cmd =~ /^b\b\s*([':A-Za-z_][':\w]*(?:\[.*\])?)\s*(.*)/ && do {
d338d6fe 1015 $subname = $1;
a223bd61 1016 $cond = length $2 ? $2 : '1';
f1583d8f 1017 cmd_b_sub($subname, $cond);
d338d6fe 1018 next CMD; };
1019 $cmd =~ /^b\b\s*(\d*)\s*(.*)/ && do {
3fbd6552 1020 $i = $1 || $line;
31706494 1021 $cond = length $2 ? $2 : '1';
f1583d8f 1022 cmd_b_line($i, $cond);
d338d6fe 1023 next CMD; };
3fbd6552 1024 $cmd =~ /^d\b\s*(\d*)/ && do {
f1583d8f 1025 cmd_d($1 || $line);
d338d6fe 1026 next CMD; };
1027 $cmd =~ /^A$/ && do {
3fbd6552 1028 print $OUT "Deleting all actions...\n";
55497cff 1029 my $file;
1030 for $file (keys %had_breakpoints) {
8ebc5c01 1031 local *dbline = $main::{'_<' . $file};
55497cff 1032 my $max = $#dbline;
1033 my $was;
1034
d338d6fe 1035 for ($i = 1; $i <= $max ; $i++) {
1036 if (defined $dbline{$i}) {
1037 $dbline{$i} =~ s/\0[^\0]*//;
1038 delete $dbline{$i} if $dbline{$i} eq '';
1039 }
1040 }
3fbd6552 1041
055fd3a9 1042 unless ($had_breakpoints{$file} &= ~2) {
3fbd6552 1043 delete $had_breakpoints{$file};
1044 }
55497cff 1045 }
1046 next CMD; };
d338d6fe 1047 $cmd =~ /^O\s*$/ && do {
1048 for (@options) {
1049 &dump_option($_);
1050 }
1051 next CMD; };
1052 $cmd =~ /^O\s*(\S.*)/ && do {
1053 parse_options($1);
1054 next CMD; };
55497cff 1055 $cmd =~ /^\<\<\s*(.*)/ && do { # \<\< for CPerl sake: not HERE
1056 push @$pre, action($1);
1057 next CMD; };
1058 $cmd =~ /^>>\s*(.*)/ && do {
1059 push @$post, action($1);
1060 next CMD; };
d338d6fe 1061 $cmd =~ /^<\s*(.*)/ && do {
055fd3a9 1062 unless ($1) {
e4e99f0d 1063 print $OUT "All < actions cleared.\n";
055fd3a9 1064 $pre = [];
1065 next CMD;
1066 }
1067 if ($1 eq '?') {
1068 unless (@$pre) {
e4e99f0d 1069 print $OUT "No pre-prompt Perl actions.\n";
055fd3a9 1070 next CMD;
1071 }
e4e99f0d 1072 print $OUT "Perl commands run before each prompt:\n";
055fd3a9 1073 for my $action ( @$pre ) {
e4e99f0d 1074 print $OUT "\t< -- $action\n";
055fd3a9 1075 }
1076 next CMD;
1077 }
55497cff 1078 $pre = [action($1)];
d338d6fe 1079 next CMD; };
1080 $cmd =~ /^>\s*(.*)/ && do {
055fd3a9 1081 unless ($1) {
e4e99f0d 1082 print $OUT "All > actions cleared.\n";
055fd3a9 1083 $post = [];
1084 next CMD;
1085 }
1086 if ($1 eq '?') {
1087 unless (@$post) {
e4e99f0d 1088 print $OUT "No post-prompt Perl actions.\n";
055fd3a9 1089 next CMD;
1090 }
e4e99f0d 1091 print $OUT "Perl commands run after each prompt:\n";
055fd3a9 1092 for my $action ( @$post ) {
e4e99f0d 1093 print $OUT "\t> -- $action\n";
055fd3a9 1094 }
1095 next CMD;
1096 }
55497cff 1097 $post = [action($1)];
1098 next CMD; };
1099 $cmd =~ /^\{\{\s*(.*)/ && do {
055fd3a9 1100 if ($cmd =~ /^\{.*\}$/ && unbalanced(substr($cmd,2))) {
e4e99f0d 1101 print $OUT "{{ is now a debugger command\n",
055fd3a9 1102 "use `;{{' if you mean Perl code\n";
1103 $cmd = "h {{";
1104 redo CMD;
1105 }
55497cff 1106 push @$pretype, $1;
1107 next CMD; };
1108 $cmd =~ /^\{\s*(.*)/ && do {
055fd3a9 1109 unless ($1) {
e4e99f0d 1110 print $OUT "All { actions cleared.\n";
055fd3a9 1111 $pretype = [];
1112 next CMD;
1113 }
1114 if ($1 eq '?') {
1115 unless (@$pretype) {
e4e99f0d 1116 print $OUT "No pre-prompt debugger actions.\n";
055fd3a9 1117 next CMD;
1118 }
e4e99f0d 1119 print $OUT "Debugger commands run before each prompt:\n";
055fd3a9 1120 for my $action ( @$pretype ) {
e4e99f0d 1121 print $OUT "\t{ -- $action\n";
055fd3a9 1122 }
1123 next CMD;
1124 }
1125 if ($cmd =~ /^\{.*\}$/ && unbalanced(substr($cmd,1))) {
e4e99f0d 1126 print $OUT "{ is now a debugger command\n",
055fd3a9 1127 "use `;{' if you mean Perl code\n";
1128 $cmd = "h {";
1129 redo CMD;
1130 }
55497cff 1131 $pretype = [$1];
d338d6fe 1132 next CMD; };
3fbd6552 1133 $cmd =~ /^a\b\s*(\d*)\s*(.*)/ && do {
1134 $i = $1 || $line; $j = $2;
1135 if (length $j) {
1136 if ($dbline[$i] == 0) {
1137 print $OUT "Line $i may not have an action.\n";
1138 } else {
1139 $had_breakpoints{$filename} |= 2;
1140 $dbline{$i} =~ s/\0[^\0]*//;
1141 $dbline{$i} .= "\0" . action($j);
1142 }
d338d6fe 1143 } else {
1144 $dbline{$i} =~ s/\0[^\0]*//;
3fbd6552 1145 delete $dbline{$i} if $dbline{$i} eq '';
d338d6fe 1146 }
1147 next CMD; };
1148 $cmd =~ /^n$/ && do {
4639966b 1149 end_report(), next CMD if $finished and $level <= 1;
d338d6fe 1150 $single = 2;
1151 $laststep = $cmd;
1152 last CMD; };
1153 $cmd =~ /^s$/ && do {
4639966b 1154 end_report(), next CMD if $finished and $level <= 1;
d338d6fe 1155 $single = 1;
1156 $laststep = $cmd;
1157 last CMD; };
54d04a52 1158 $cmd =~ /^c\b\s*([\w:]*)\s*$/ && do {
4639966b 1159 end_report(), next CMD if $finished and $level <= 1;
fb73857a 1160 $subname = $i = $1;
bee32ff8 1161 # Probably not needed, since we finish an interactive
1162 # sub-session anyway...
1163 # local $filename = $filename;
1164 # local *dbline = *dbline; # XXX Would this work?!
54d04a52 1165 if ($i =~ /\D/) { # subroutine name
fb73857a 1166 $subname = $package."::".$subname
1167 unless $subname =~ /::/;
1168 ($file,$i) = (find_sub($subname) =~ /^(.*):(.*)$/);
54d04a52 1169 $i += 0;
1170 if ($i) {
1171 $filename = $file;
8ebc5c01 1172 *dbline = $main::{'_<' . $filename};
3fbd6552 1173 $had_breakpoints{$filename} |= 1;
54d04a52 1174 $max = $#dbline;
1175 ++$i while $dbline[$i] == 0 && $i < $max;
1176 } else {
1177 print $OUT "Subroutine $subname not found.\n";
1178 next CMD;
1179 }
1180 }
d338d6fe 1181 if ($i) {
1182 if ($dbline[$i] == 0) {
1183 print $OUT "Line $i not breakable.\n";
1184 next CMD;
1185 }
1186 $dbline{$i} =~ s/($|\0)/;9$1/; # add one-time-only b.p.
1187 }
f8b5b99c 1188 for ($i=0; $i <= $stack_depth; ) {
d338d6fe 1189 $stack[$i++] &= ~1;
1190 }
1191 last CMD; };
1192 $cmd =~ /^r$/ && do {
4639966b 1193 end_report(), next CMD if $finished and $level <= 1;
f8b5b99c 1194 $stack[$stack_depth] |= 1;
1195 $doret = $option{PrintRet} ? $stack_depth - 1 : -2;
d338d6fe 1196 last CMD; };
54d04a52 1197 $cmd =~ /^R$/ && do {
55497cff 1198 print $OUT "Warning: some settings and command-line options may be lost!\n";
54d04a52 1199 my (@script, @flags, $cl);
1200 push @flags, '-w' if $ini_warn;
1201 # Put all the old includes at the start to get
1202 # the same debugger.
1203 for (@ini_INC) {
1204 push @flags, '-I', $_;
1205 }
1206 # Arrange for setting the old INC:
1207 set_list("PERLDB_INC", @ini_INC);
1208 if ($0 eq '-e') {
1209 for (1..$#{'::_<-e'}) { # The first line is PERL5DB
055fd3a9 1210 chomp ($cl = ${'::_<-e'}[$_]);
54d04a52 1211 push @script, '-e', $cl;
1212 }
1213 } else {
1214 @script = $0;
1215 }
1216 set_list("PERLDB_HIST",
1217 $term->Features->{getHistory}
1218 ? $term->GetHistory : @hist);
55497cff 1219 my @had_breakpoints = keys %had_breakpoints;
1220 set_list("PERLDB_VISITED", @had_breakpoints);
54d04a52 1221 set_list("PERLDB_OPT", %option);
55497cff 1222 set_list("PERLDB_ON_LOAD", %break_on_load);
1223 my @hard;
1224 for (0 .. $#had_breakpoints) {
1225 my $file = $had_breakpoints[$_];
8ebc5c01 1226 *dbline = $main::{'_<' . $file};
0c395bd7 1227 next unless %dbline or $postponed_file{$file};
55497cff 1228 (push @hard, $file), next
1229 if $file =~ /^\(eval \d+\)$/;
1230 my @add;
1231 @add = %{$postponed_file{$file}}
0c395bd7 1232 if $postponed_file{$file};
55497cff 1233 set_list("PERLDB_FILE_$_", %dbline, @add);
1234 }
1235 for (@hard) { # Yes, really-really...
1236 # Find the subroutines in this eval
8ebc5c01 1237 *dbline = $main::{'_<' . $_};
55497cff 1238 my ($quoted, $sub, %subs, $line) = quotemeta $_;
1239 for $sub (keys %sub) {
1240 next unless $sub{$sub} =~ /^$quoted:(\d+)-(\d+)$/;
1241 $subs{$sub} = [$1, $2];
1242 }
1243 unless (%subs) {
1244 print $OUT
1245 "No subroutines in $_, ignoring breakpoints.\n";
1246 next;
1247 }
1248 LINES: for $line (keys %dbline) {
1249 # One breakpoint per sub only:
1250 my ($offset, $sub, $found);
1251 SUBS: for $sub (keys %subs) {
1252 if ($subs{$sub}->[1] >= $line # Not after the subroutine
1253 and (not defined $offset # Not caught
1254 or $offset < 0 )) { # or badly caught
1255 $found = $sub;
1256 $offset = $line - $subs{$sub}->[0];
1257 $offset = "+$offset", last SUBS if $offset >= 0;
1258 }
1259 }
1260 if (defined $offset) {
1261 $postponed{$found} =
1262 "break $offset if $dbline{$line}";
1263 } else {
1264 print $OUT "Breakpoint in $_:$line ignored: after all the subroutines.\n";
1265 }
1266 }
54d04a52 1267 }
55497cff 1268 set_list("PERLDB_POSTPONE", %postponed);
43aed9ee 1269 set_list("PERLDB_PRETYPE", @$pretype);
1270 set_list("PERLDB_PRE", @$pre);
1271 set_list("PERLDB_POST", @$post);
1272 set_list("PERLDB_TYPEAHEAD", @typeahead);
54d04a52 1273 $ENV{PERLDB_RESTART} = 1;
f1583d8f 1274 delete $ENV{PERLDB_PIDS}; # Restore ini state
1275 $ENV{PERLDB_PIDS} = $ini_pids if defined $ini_pids;
055fd3a9 1276 #print "$^X, '-d', @flags, @script, ($slave_editor ? '-emacs' : ()), @ARGS";
04e43a21 1277 exec($^X, '-d', @flags, @script, ($slave_editor ? '-emacs' : ()), @ARGS) ||
54d04a52 1278 print $OUT "exec failed: $!\n";
1279 last CMD; };
d338d6fe 1280 $cmd =~ /^T$/ && do {
36477c24 1281 print_trace($OUT, 1); # skip DB
d338d6fe 1282 next CMD; };
6027b9a3 1283 $cmd =~ /^W\s*$/ && do {
1284 $trace &= ~2;
1285 @to_watch = @old_watch = ();
1286 next CMD; };
1287 $cmd =~ /^W\b\s*(.*)/s && do {
1288 push @to_watch, $1;
1289 $evalarg = $1;
1290 my ($val) = &eval;
1291 $val = (defined $val) ? "'$val'" : 'undef' ;
1292 push @old_watch, $val;
1293 $trace |= 2;
1294 next CMD; };
d338d6fe 1295 $cmd =~ /^\/(.*)$/ && do {
1296 $inpat = $1;
1297 $inpat =~ s:([^\\])/$:$1:;
1298 if ($inpat ne "") {
3dcd9d33 1299 # squelch the sigmangler
1300 local $SIG{__DIE__};
1301 local $SIG{__WARN__};
d338d6fe 1302 eval '$inpat =~ m'."\a$inpat\a";
1303 if ($@ ne "") {
1304 print $OUT "$@";
1305 next CMD;
1306 }
1307 $pat = $inpat;
1308 }
1309 $end = $start;
1d06cb2d 1310 $incr = -1;
d338d6fe 1311 eval '
1312 for (;;) {
1313 ++$start;
1314 $start = 1 if ($start > $max);
1315 last if ($start == $end);
1316 if ($dbline[$start] =~ m' . "\a$pat\a" . 'i) {
055fd3a9 1317 if ($slave_editor) {
d338d6fe 1318 print $OUT "\032\032$filename:$start:0\n";
1319 } else {
1320 print $OUT "$start:\t", $dbline[$start], "\n";
1321 }
1322 last;
1323 }
1324 } ';
1325 print $OUT "/$pat/: not found\n" if ($start == $end);
1326 next CMD; };
1327 $cmd =~ /^\?(.*)$/ && do {
1328 $inpat = $1;
1329 $inpat =~ s:([^\\])\?$:$1:;
1330 if ($inpat ne "") {
3dcd9d33 1331 # squelch the sigmangler
1332 local $SIG{__DIE__};
1333 local $SIG{__WARN__};
d338d6fe 1334 eval '$inpat =~ m'."\a$inpat\a";
1335 if ($@ ne "") {
3dcd9d33 1336 print $OUT $@;
d338d6fe 1337 next CMD;
1338 }
1339 $pat = $inpat;
1340 }
1341 $end = $start;
1d06cb2d 1342 $incr = -1;
d338d6fe 1343 eval '
1344 for (;;) {
1345 --$start;
1346 $start = $max if ($start <= 0);
1347 last if ($start == $end);
1348 if ($dbline[$start] =~ m' . "\a$pat\a" . 'i) {
055fd3a9 1349 if ($slave_editor) {
d338d6fe 1350 print $OUT "\032\032$filename:$start:0\n";
1351 } else {
1352 print $OUT "$start:\t", $dbline[$start], "\n";
1353 }
1354 last;
1355 }
1356 } ';
1357 print $OUT "?$pat?: not found\n" if ($start == $end);
1358 next CMD; };
1359 $cmd =~ /^$rc+\s*(-)?(\d+)?$/ && do {
1360 pop(@hist) if length($cmd) > 1;
3fbd6552 1361 $i = $1 ? ($#hist-($2||1)) : ($2||$#hist);
6921e3ed 1362 $cmd = $hist[$i];
615b993b 1363 print $OUT $cmd, "\n";
d338d6fe 1364 redo CMD; };
55497cff 1365 $cmd =~ /^$sh$sh\s*([\x00-\xff]*)/ && do {
ee971a18 1366 &system($1);
d338d6fe 1367 next CMD; };
1368 $cmd =~ /^$rc([^$rc].*)$/ && do {
1369 $pat = "^$1";
1370 pop(@hist) if length($cmd) > 1;
1371 for ($i = $#hist; $i; --$i) {
1372 last if $hist[$i] =~ /$pat/;
1373 }
1374 if (!$i) {
1375 print $OUT "No such command!\n\n";
1376 next CMD;
1377 }
6921e3ed 1378 $cmd = $hist[$i];
615b993b 1379 print $OUT $cmd, "\n";
d338d6fe 1380 redo CMD; };
1381 $cmd =~ /^$sh$/ && do {
1382 &system($ENV{SHELL}||"/bin/sh");
1383 next CMD; };
ee971a18 1384 $cmd =~ /^$sh\s*([\x00-\xff]*)/ && do {
055fd3a9 1385 # XXX: using csh or tcsh destroys sigint retvals!
1386 #&system($1); # use this instead
ee971a18 1387 &system($ENV{SHELL}||"/bin/sh","-c",$1);
d338d6fe 1388 next CMD; };
1389 $cmd =~ /^H\b\s*(-(\d+))?/ && do {
055fd3a9 1390 $end = $2 ? ($#hist-$2) : 0;
d338d6fe 1391 $hist = 0 if $hist < 0;
1392 for ($i=$#hist; $i>$end; $i--) {
1393 print $OUT "$i: ",$hist[$i],"\n"
1394 unless $hist[$i] =~ /^.?$/;
1395 };
1396 next CMD; };
055fd3a9 1397 $cmd =~ /^(?:man|(?:perl)?doc)\b(?:\s+([^(]*))?$/ && do {
1398 runman($1);
1399 next CMD; };
b9b857e2 1400 $cmd =~ s/^p$/print {\$DB::OUT} \$_/;
1401 $cmd =~ s/^p\b/print {\$DB::OUT} /;
3dcd9d33 1402 $cmd =~ s/^=\s*// && do {
1403 my @keys;
1404 if (length $cmd == 0) {
1405 @keys = sort keys %alias;
1406 }
1407 elsif (my($k,$v) = ($cmd =~ /^(\S+)\s+(\S.*)/)) {
1408 # can't use $_ or kill //g state
1409 for my $x ($k, $v) { $x =~ s/\a/\\a/g }
1410 $alias{$k} = "s\a$k\a$v\a";
1411 # squelch the sigmangler
1412 local $SIG{__DIE__};
1413 local $SIG{__WARN__};
1414 unless (eval "sub { s\a$k\a$v\a }; 1") {
1415 print $OUT "Can't alias $k to $v: $@\n";
1416 delete $alias{$k};
1417 next CMD;
1418 }
1419 @keys = ($k);
1420 }
1421 else {
1422 @keys = ($cmd);
1423 }
1424 for my $k (@keys) {
1425 if ((my $v = $alias{$k}) =~ s\as\a$k\a(.*)\a$\a1\a) {
1426 print $OUT "$k\t= $1\n";
1427 }
1428 elsif (defined $alias{$k}) {
d338d6fe 1429 print $OUT "$k\t$alias{$k}\n";
3dcd9d33 1430 }
1431 else {
1432 print "No alias for $k\n";
1433 }
1434 }
d338d6fe 1435 next CMD; };
1436 $cmd =~ /^\|\|?\s*[^|]/ && do {
1437 if ($pager =~ /^\|/) {
1438 open(SAVEOUT,">&STDOUT") || &warn("Can't save STDOUT");
1439 open(STDOUT,">&OUT") || &warn("Can't redirect STDOUT");
1440 } else {
1441 open(SAVEOUT,">&OUT") || &warn("Can't save DB::OUT");
1442 }
055fd3a9 1443 fix_less();
d338d6fe 1444 unless ($piped=open(OUT,$pager)) {
1445 &warn("Can't pipe output to `$pager'");
1446 if ($pager =~ /^\|/) {
055fd3a9 1447 open(OUT,">&STDOUT") # XXX: lost message
1448 || &warn("Can't restore DB::OUT");
d338d6fe 1449 open(STDOUT,">&SAVEOUT")
1450 || &warn("Can't restore STDOUT");
1451 close(SAVEOUT);
1452 } else {
055fd3a9 1453 open(OUT,">&STDOUT") # XXX: lost message
1454 || &warn("Can't restore DB::OUT");
d338d6fe 1455 }
1456 next CMD;
1457 }
77fb7b16 1458 $SIG{PIPE}= \&DB::catch if $pager =~ /^\|/
055fd3a9 1459 && ("" eq $SIG{PIPE} || "DEFAULT" eq $SIG{PIPE});
d338d6fe 1460 $selected= select(OUT);
1461 $|= 1;
1462 select( $selected ), $selected= "" unless $cmd =~ /^\|\|/;
1463 $cmd =~ s/^\|+\s*//;
055fd3a9 1464 redo PIPE;
1465 };
d338d6fe 1466 # XXX Local variants do not work!
6027b9a3 1467 $cmd =~ s/^t\s/\$DB::trace |= 1;\n/;
d338d6fe 1468 $cmd =~ s/^s\s/\$DB::single = 1;\n/ && do {$laststep = 's'};
1469 $cmd =~ s/^n\s/\$DB::single = 2;\n/ && do {$laststep = 'n'};
1470 } # PIPE:
d338d6fe 1471 $evalarg = "\$^D = \$^D | \$DB::db_stop;\n$cmd"; &eval;
1472 if ($onetimeDump) {
1473 $onetimeDump = undef;
f36776d9 1474 } elsif ($term_pid == $$) {
d338d6fe 1475 print $OUT "\n";
1476 }
1477 } continue { # CMD:
1478 if ($piped) {
1479 if ($pager =~ /^\|/) {
055fd3a9 1480 $? = 0;
1481 # we cannot warn here: the handle is missing --tchrist
1482 close(OUT) || print SAVEOUT "\nCan't close DB::OUT\n";
1483
1484 # most of the $? crud was coping with broken cshisms
1485 if ($?) {
1486 print SAVEOUT "Pager `$pager' failed: ";
1487 if ($? == -1) {
1488 print SAVEOUT "shell returned -1\n";
1489 } elsif ($? >> 8) {
1490 print SAVEOUT
1491 ( $? & 127 ) ? " (SIG#".($?&127).")" : "",
1492 ( $? & 128 ) ? " -- core dumped" : "", "\n";
1493 } else {
1494 print SAVEOUT "status ", ($? >> 8), "\n";
1495 }
1496 }
1497
d338d6fe 1498 open(OUT,">&STDOUT") || &warn("Can't restore DB::OUT");
1499 open(STDOUT,">&SAVEOUT") || &warn("Can't restore STDOUT");
055fd3a9 1500 $SIG{PIPE} = "DEFAULT" if $SIG{PIPE} eq \&DB::catch;
d338d6fe 1501 # Will stop ignoring SIGPIPE if done like nohup(1)
1502 # does SIGINT but Perl doesn't give us a choice.
1503 } else {
1504 open(OUT,">&SAVEOUT") || &warn("Can't restore DB::OUT");
1505 }
1506 close(SAVEOUT);
1507 select($selected), $selected= "" unless $selected eq "";
1508 $piped= "";
1509 }
1510 } # CMD:
20928eff 1511 $fall_off_end = 1 unless defined $cmd; # Emulate `q' on EOF
e63173ce 1512 foreach $evalarg (@$post) {
1513 &eval;
1514 }
d338d6fe 1515 } # if ($single || $signal)
22fae026 1516 ($@, $!, $^E, $,, $/, $\, $^W) = @saved;
d338d6fe 1517 ();
1518}
1519
1520# The following code may be executed now:
1521# BEGIN {warn 4}
1522
1523sub sub {
ee971a18 1524 my ($al, $ret, @ret) = "";
7d4a81e5 1525 if (length($sub) > 10 && substr($sub, -10, 10) eq '::AUTOLOAD') {
1526 $al = " for $$sub";
ee971a18 1527 }
f8b5b99c 1528 local $stack_depth = $stack_depth + 1; # Protect from non-local exits
1529 $#stack = $stack_depth;
1530 $stack[-1] = $single;
d338d6fe 1531 $single &= 1;
f8b5b99c 1532 $single |= 4 if $stack_depth == $deep;
04fb8f4b 1533 ($frame & 4
f1583d8f 1534 ? ( print_lineinfo(' ' x ($stack_depth - 1), "in "),
04fb8f4b 1535 # Why -1? But it works! :-(
1536 print_trace($LINEINFO, -1, 1, 1, "$sub$al") )
f1583d8f 1537 : print_lineinfo(' ' x ($stack_depth - 1), "entering $sub$al\n")) if $frame;
d338d6fe 1538 if (wantarray) {
1539 @ret = &$sub;
f8b5b99c 1540 $single |= $stack[$stack_depth--];
36477c24 1541 ($frame & 4
f1583d8f 1542 ? ( print_lineinfo(' ' x $stack_depth, "out "),
36477c24 1543 print_trace($LINEINFO, -1, 1, 1, "$sub$al") )
f1583d8f 1544 : print_lineinfo(' ' x $stack_depth, "exited $sub$al\n")) if $frame & 2;
f8b5b99c 1545 if ($doret eq $stack_depth or $frame & 16) {
1546 my $fh = ($doret eq $stack_depth ? $OUT : $LINEINFO);
1547 print $fh ' ' x $stack_depth if $frame & 16;
7ea36084 1548 print $fh "list context return from $sub:\n";
1549 dumpit($fh, \@ret );
1550 $doret = -2;
1551 }
d338d6fe 1552 @ret;
1553 } else {
fb73857a 1554 if (defined wantarray) {
1555 $ret = &$sub;
1556 } else {
1557 &$sub; undef $ret;
1558 };
f8b5b99c 1559 $single |= $stack[$stack_depth--];
36477c24 1560 ($frame & 4
f1583d8f 1561 ? ( print_lineinfo(' ' x $stack_depth, "out "),
36477c24 1562 print_trace($LINEINFO, -1, 1, 1, "$sub$al") )
f1583d8f 1563 : print_lineinfo(' ' x $stack_depth, "exited $sub$al\n")) if $frame & 2;
f8b5b99c 1564 if ($doret eq $stack_depth or $frame & 16 and defined wantarray) {
1565 my $fh = ($doret eq $stack_depth ? $OUT : $LINEINFO);
1566 print $fh (' ' x $stack_depth) if $frame & 16;
7ea36084 1567 print $fh (defined wantarray
1568 ? "scalar context return from $sub: "
1569 : "void context return from $sub\n");
1570 dumpit( $fh, $ret ) if defined wantarray;
1571 $doret = -2;
1572 }
d338d6fe 1573 $ret;
1574 }
1575}
1576
f1583d8f 1577### The API section
1578
1579### Functions with multiple modes of failure die on error, the rest
1580### returns FALSE on error.
1581### User-interface functions cmd_* output error message.
1582
1583sub break_on_load {
1584 my $file = shift;
1585 $break_on_load{$file} = 1;
1586 $had_breakpoints{$file} |= 1;
1587}
1588
1589sub report_break_on_load {
1590 sort keys %break_on_load;
1591}
1592
1593sub cmd_b_load {
1594 my $file = shift;
1595 my @files;
1596 {
1597 push @files, $file;
1598 push @files, $::INC{$file} if $::INC{$file};
1599 $file .= '.pm', redo unless $file =~ /\./;
1600 }
1601 break_on_load($_) for @files;
04e43a21 1602 @files = report_break_on_load;
f1583d8f 1603 print $OUT "Will stop on load of `@files'.\n";
1604}
1605
1606$filename_error = '';
1607
1608sub breakable_line {
1609 my ($from, $to) = @_;
1610 my $i = $from;
1611 if (@_ >= 2) {
1612 my $delta = $from < $to ? +1 : -1;
1613 my $limit = $delta > 0 ? $#dbline : 1;
1614 $limit = $to if ($limit - $to) * $delta > 0;
1615 $i += $delta while $dbline[$i] == 0 and ($limit - $i) * $delta > 0;
1616 }
1617 return $i unless $dbline[$i] == 0;
1618 my ($pl, $upto) = ('', '');
1619 ($pl, $upto) = ('s', "..$to") if @_ >=2 and $from != $to;
1620 die "Line$pl $from$upto$filename_error not breakable\n";
1621}
1622
1623sub breakable_line_in_filename {
1624 my ($f) = shift;
1625 local *dbline = $main::{'_<' . $f};
1626 local $filename_error = " of `$f'";
1627 breakable_line(@_);
1628}
1629
1630sub break_on_line {
1631 my ($i, $cond) = @_;
1632 $cond = 1 unless @_ >= 2;
1633 my $inii = $i;
1634 my $after = '';
1635 my $pl = '';
1636 die "Line $i$filename_error not breakable.\n" if $dbline[$i] == 0;
1637 $had_breakpoints{$filename} |= 1;
22c4a518 1638 if ($dbline{$i}) { $dbline{$i} =~ s/^[^\0]*/$cond/; }
1639 else { $dbline{$i} = $cond; }
f1583d8f 1640}
1641
1642sub cmd_b_line {
1643 eval { break_on_line(@_); 1 } or print $OUT $@ and return;
1644}
1645
1646sub break_on_filename_line {
1647 my ($f, $i, $cond) = @_;
1648 $cond = 1 unless @_ >= 3;
1649 local *dbline = $main::{'_<' . $f};
1650 local $filename_error = " of `$f'";
1651 local $filename = $f;
1652 break_on_line($i, $cond);
1653}
1654
1655sub break_on_filename_line_range {
1656 my ($f, $from, $to, $cond) = @_;
1657 my $i = breakable_line_in_filename($f, $from, $to);
1658 $cond = 1 unless @_ >= 3;
1659 break_on_filename_line($f,$i,$cond);
1660}
1661
1662sub subroutine_filename_lines {
1663 my ($subname,$cond) = @_;
1664 # Filename below can contain ':'
1665 find_sub($subname) =~ /^(.*):(\d+)-(\d+)$/;
1666}
1667
1668sub break_subroutine {
1669 my $subname = shift;
1670 my ($file,$s,$e) = subroutine_filename_lines($subname) or
1671 die "Subroutine $subname not found.\n";
1672 $cond = 1 unless @_ >= 2;
1673 break_on_filename_line_range($file,$s,$e,@_);
1674}
1675
1676sub cmd_b_sub {
1677 my ($subname,$cond) = @_;
1678 $cond = 1 unless @_ >= 2;
1679 unless (ref $subname eq 'CODE') {
1680 $subname =~ s/\'/::/g;
1681 my $s = $subname;
1682 $subname = "${'package'}::" . $subname
1683 unless $subname =~ /::/;
1684 $subname = "CORE::GLOBAL::$s"
1685 if not defined &$subname and $s !~ /::/ and defined &{"CORE::GLOBAL::$s"};
1686 $subname = "main".$subname if substr($subname,0,2) eq "::";
1687 }
1688 eval { break_subroutine($subname,$cond); 1 } or print $OUT $@ and return;
1689}
1690
1691sub cmd_stop { # As on ^C, but not signal-safy.
1692 $signal = 1;
1693}
1694
1695sub delete_breakpoint {
1696 my $i = shift;
1697 die "Line $i not breakable.\n" if $dbline[$i] == 0;
1698 $dbline{$i} =~ s/^[^\0]*//;
1699 delete $dbline{$i} if $dbline{$i} eq '';
1700}
1701
1702sub cmd_d {
1703 my $i = shift;
1704 eval { delete_breakpoint $i; 1 } or print $OUT $@ and return;
1705}
1706
1707### END of the API section
1708
d338d6fe 1709sub save {
22fae026 1710 @saved = ($@, $!, $^E, $,, $/, $\, $^W);
d338d6fe 1711 $, = ""; $/ = "\n"; $\ = ""; $^W = 0;
1712}
1713
f1583d8f 1714sub print_lineinfo {
1715 resetterm(1) if $LINEINFO eq $OUT and $term_pid != $$;
1716 print $LINEINFO @_;
1717}
1718
d338d6fe 1719# The following takes its argument via $evalarg to preserve current @_
1720
1721sub eval {
055fd3a9 1722 # 'my' would make it visible from user code
f1583d8f 1723 # but so does local! --tchrist [... into @DB::res, not @res. IZ]
1724 local @res;
d338d6fe 1725 {
23a291ec 1726 local $otrace = $trace;
1727 local $osingle = $single;
1728 local $od = $^D;
157b066d 1729 { ($evalarg) = $evalarg =~ /(.*)/s; }
d338d6fe 1730 @res = eval "$usercontext $evalarg;\n"; # '\n' for nice recursive debug
1731 $trace = $otrace;
1732 $single = $osingle;
1733 $^D = $od;
1734 }
1735 my $at = $@;
36477c24 1736 local $saved[0]; # Preserve the old value of $@
22fae026 1737 eval { &DB::save };
62769f13 1738 if ($at) {
d338d6fe 1739 print $OUT $at;
600d99fa 1740 } elsif ($onetimeDump) {
1741 dumpit($OUT, \@res) if $onetimeDump eq 'dump';
1742 methods($res[0]) if $onetimeDump eq 'methods';
d338d6fe 1743 }
6027b9a3 1744 @res;
d338d6fe 1745}
1746
55497cff 1747sub postponed_sub {
1748 my $subname = shift;
1d06cb2d 1749 if ($postponed{$subname} =~ s/^break\s([+-]?\d+)\s+if\s//) {
55497cff 1750 my $offset = $1 || 0;
1751 # Filename below can contain ':'
1d06cb2d 1752 my ($file,$i) = (find_sub($subname) =~ /^(.*):(\d+)-.*$/);
55497cff 1753 if ($i) {
fb73857a 1754 $i += $offset;
8ebc5c01 1755 local *dbline = $main::{'_<' . $file};
55497cff 1756 local $^W = 0; # != 0 is magical below
3fbd6552 1757 $had_breakpoints{$file} |= 1;
55497cff 1758 my $max = $#dbline;
1759 ++$i until $dbline[$i] != 0 or $i >= $max;
1760 $dbline{$i} = delete $postponed{$subname};
1761 } else {
1762 print $OUT "Subroutine $subname not found.\n";
1763 }
1764 return;
1765 }
1d06cb2d 1766 elsif ($postponed{$subname} eq 'compile') { $signal = 1 }
36477c24 1767 #print $OUT "In postponed_sub for `$subname'.\n";
55497cff 1768}
1769
1770sub postponed {
3aefca04 1771 if ($ImmediateStop) {
1772 $ImmediateStop = 0;
1773 $signal = 1;
1774 }
55497cff 1775 return &postponed_sub
1776 unless ref \$_[0] eq 'GLOB'; # A subroutine is compiled.
1777 # Cannot be done before the file is compiled
1778 local *dbline = shift;
1779 my $filename = $dbline;
1780 $filename =~ s/^_<//;
36477c24 1781 $signal = 1, print $OUT "'$filename' loaded...\n"
1782 if $break_on_load{$filename};
f1583d8f 1783 print_lineinfo(' ' x $stack_depth, "Package $filename.\n") if $frame;
0c395bd7 1784 return unless $postponed_file{$filename};
3fbd6552 1785 $had_breakpoints{$filename} |= 1;
55497cff 1786 #%dbline = %{$postponed_file{$filename}}; # Cannot be done: unsufficient magic
1787 my $key;
1788 for $key (keys %{$postponed_file{$filename}}) {
055fd3a9 1789 $dbline{$key} = ${$postponed_file{$filename}}{$key};
54d04a52 1790 }
0c395bd7 1791 delete $postponed_file{$filename};
54d04a52 1792}
1793
d338d6fe 1794sub dumpit {
7ea36084 1795 local ($savout) = select(shift);
ee971a18 1796 my $osingle = $single;
1797 my $otrace = $trace;
1798 $single = $trace = 0;
1799 local $frame = 0;
1800 local $doret = -2;
1801 unless (defined &main::dumpValue) {
1802 do 'dumpvar.pl';
1803 }
d338d6fe 1804 if (defined &main::dumpValue) {
1805 &main::dumpValue(shift);
1806 } else {
1807 print $OUT "dumpvar.pl not available.\n";
1808 }
ee971a18 1809 $single = $osingle;
1810 $trace = $otrace;
d338d6fe 1811 select ($savout);
1812}
1813
36477c24 1814# Tied method do not create a context, so may get wrong message:
1815
55497cff 1816sub print_trace {
1817 my $fh = shift;
f1583d8f 1818 resetterm(1) if $fh eq $LINEINFO and $LINEINFO eq $OUT and $term_pid != $$;
36477c24 1819 my @sub = dump_trace($_[0] + 1, $_[1]);
1820 my $short = $_[2]; # Print short report, next one for sub name
1d06cb2d 1821 my $s;
55497cff 1822 for ($i=0; $i <= $#sub; $i++) {
1823 last if $signal;
1824 local $" = ', ';
1825 my $args = defined $sub[$i]{args}
1826 ? "(@{ $sub[$i]{args} })"
1827 : '' ;
1d06cb2d 1828 $args = (substr $args, 0, $maxtrace - 3) . '...'
1829 if length $args > $maxtrace;
36477c24 1830 my $file = $sub[$i]{file};
1831 $file = $file eq '-e' ? $file : "file `$file'" unless $short;
1d06cb2d 1832 $s = $sub[$i]{sub};
1833 $s = (substr $s, 0, $maxtrace - 3) . '...' if length $s > $maxtrace;
36477c24 1834 if ($short) {
1d06cb2d 1835 my $sub = @_ >= 4 ? $_[3] : $s;
36477c24 1836 print $fh "$sub[$i]{context}=$sub$args from $file:$sub[$i]{line}\n";
1837 } else {
1d06cb2d 1838 print $fh "$sub[$i]{context} = $s$args" .
36477c24 1839 " called from $file" .
1840 " line $sub[$i]{line}\n";
1841 }
55497cff 1842 }
1843}
1844
1845sub dump_trace {
1846 my $skip = shift;
36477c24 1847 my $count = shift || 1e9;
1848 $skip++;
1849 $count += $skip;
55497cff 1850 my ($p,$file,$line,$sub,$h,$args,$e,$r,@a,@sub,$context);
04fb8f4b 1851 my $nothard = not $frame & 8;
1852 local $frame = 0; # Do not want to trace this.
1853 my $otrace = $trace;
1854 $trace = 0;
55497cff 1855 for ($i = $skip;
36477c24 1856 $i < $count and ($p,$file,$line,$sub,$h,$context,$e,$r) = caller($i);
55497cff 1857 $i++) {
1858 @a = ();
1859 for $arg (@args) {
04fb8f4b 1860 my $type;
1861 if (not defined $arg) {
1862 push @a, "undef";
1863 } elsif ($nothard and tied $arg) {
1864 push @a, "tied";
1865 } elsif ($nothard and $type = ref $arg) {
1866 push @a, "ref($type)";
1867 } else {
1868 local $_ = "$arg"; # Safe to stringify now - should not call f().
1869 s/([\'\\])/\\$1/g;
1870 s/(.*)/'$1'/s
1871 unless /^(?: -?[\d.]+ | \*[\w:]* )$/x;
1872 s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg;
1873 s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg;
1874 push(@a, $_);
1875 }
55497cff 1876 }
7ea36084 1877 $context = $context ? '@' : (defined $context ? "\$" : '.');
55497cff 1878 $args = $h ? [@a] : undef;
1879 $e =~ s/\n\s*\;\s*\Z// if $e;
1d06cb2d 1880 $e =~ s/([\\\'])/\\$1/g if $e;
55497cff 1881 if ($r) {
1882 $sub = "require '$e'";
1883 } elsif (defined $r) {
1884 $sub = "eval '$e'";
1885 } elsif ($sub eq '(eval)') {
1886 $sub = "eval {...}";
1887 }
1888 push(@sub, {context => $context, sub => $sub, args => $args,
1889 file => $file, line => $line});
1890 last if $signal;
1891 }
04fb8f4b 1892 $trace = $otrace;
55497cff 1893 @sub;
1894}
1895
d338d6fe 1896sub action {
1897 my $action = shift;
1898 while ($action =~ s/\\$//) {
1899 #print $OUT "+ ";
1900 #$action .= "\n";
1901 $action .= &gets;
1902 }
1903 $action;
1904}
1905
055fd3a9 1906sub unbalanced {
1907 # i hate using globals!
1908 $balanced_brace_re ||= qr{
1909 ^ \{
1910 (?:
1911 (?> [^{}] + ) # Non-parens without backtracking
1912 |
1913 (??{ $balanced_brace_re }) # Group with matching parens
1914 ) *
1915 \} $
1916 }x;
1917 return $_[0] !~ m/$balanced_brace_re/;
1918}
1919
d338d6fe 1920sub gets {
d338d6fe 1921 &readline("cont: ");
1922}
1923
1924sub system {
1925 # We save, change, then restore STDIN and STDOUT to avoid fork() since
055fd3a9 1926 # some non-Unix systems can do system() but have problems with fork().
d338d6fe 1927 open(SAVEIN,"<&STDIN") || &warn("Can't save STDIN");
8ee058cb 1928 open(SAVEOUT,">&STDOUT") || &warn("Can't save STDOUT");
d338d6fe 1929 open(STDIN,"<&IN") || &warn("Can't redirect STDIN");
1930 open(STDOUT,">&OUT") || &warn("Can't redirect STDOUT");
055fd3a9 1931
1932 # XXX: using csh or tcsh destroys sigint retvals!
d338d6fe 1933 system(@_);
1934 open(STDIN,"<&SAVEIN") || &warn("Can't restore STDIN");
1935 open(STDOUT,">&SAVEOUT") || &warn("Can't restore STDOUT");
055fd3a9 1936 close(SAVEIN);
1937 close(SAVEOUT);
1938
1939
1940 # most of the $? crud was coping with broken cshisms
1941 if ($? >> 8) {
1942 &warn("(Command exited ", ($? >> 8), ")\n");
1943 } elsif ($?) {
1944 &warn( "(Command died of SIG#", ($? & 127),
1945 (($? & 128) ? " -- core dumped" : "") , ")", "\n");
1946 }
1947
1948 return $?;
1949
d338d6fe 1950}
1951
1952sub setterm {
54d04a52 1953 local $frame = 0;
ee971a18 1954 local $doret = -2;
ee971a18 1955 eval { require Term::ReadLine } or die $@;
d338d6fe 1956 if ($notty) {
1957 if ($tty) {
f1583d8f 1958 my ($i, $o) = split $tty, /,/;
1959 $o = $i unless defined $o;
1960 open(IN,"<$i") or die "Cannot open TTY `$i' for read: $!";
1961 open(OUT,">$o") or die "Cannot open TTY `$o' for write: $!";
d338d6fe 1962 $IN = \*IN;
1963 $OUT = \*OUT;
1964 my $sel = select($OUT);
1965 $| = 1;
1966 select($sel);
1967 } else {
3dcd9d33 1968 eval "require Term::Rendezvous;" or die;
d338d6fe 1969 my $rv = $ENV{PERLDB_NOTTY} || "/tmp/perldbtty$$";
1970 my $term_rv = new Term::Rendezvous $rv;
1971 $IN = $term_rv->IN;
1972 $OUT = $term_rv->OUT;
1973 }
1974 }
f1583d8f 1975 if ($term_pid eq '-1') { # In a TTY with another debugger
1976 resetterm(2);
1977 }
d338d6fe 1978 if (!$rl) {
1979 $term = new Term::ReadLine::Stub 'perldb', $IN, $OUT;
1980 } else {
1981 $term = new Term::ReadLine 'perldb', $IN, $OUT;
1982
a737e074 1983 $rl_attribs = $term->Attribs;
1984 $rl_attribs->{basic_word_break_characters} .= '-:+/*,[])}'
1985 if defined $rl_attribs->{basic_word_break_characters}
1986 and index($rl_attribs->{basic_word_break_characters}, ":") == -1;
1987 $rl_attribs->{special_prefixes} = '$@&%';
1988 $rl_attribs->{completer_word_break_characters} .= '$@&%';
1989 $rl_attribs->{completion_function} = \&db_complete;
d338d6fe 1990 }
1991 $LINEINFO = $OUT unless defined $LINEINFO;
1992 $lineinfo = $console unless defined $lineinfo;
1993 $term->MinLine(2);
54d04a52 1994 if ($term->Features->{setHistory} and "@hist" ne "?") {
1995 $term->SetHistory(@hist);
1996 }
7a2e2cd6 1997 ornaments($ornaments) if defined $ornaments;
f36776d9 1998 $term_pid = $$;
1999}
2000
f1583d8f 2001# Example get_fork_TTY functions
2002sub xterm_get_fork_TTY {
2003 (my $name = $0) =~ s,^.*[/\\],,s;
2004 open XT, qq[3>&1 xterm -title "Daughter Perl debugger $pids $name" -e sh -c 'tty 1>&3;\
f36776d9 2005 sleep 10000000' |];
f1583d8f 2006 my $tty = <XT>;
2007 chomp $tty;
2008 $pidprompt = ''; # Shown anyway in titlebar
2009 return $tty;
2010}
2011
2012# This one resets $IN, $OUT itself
2013sub os2_get_fork_TTY {
2014 $^F = 40; # XXXX Fixme!
2015 my ($in1, $out1, $in2, $out2);
2016 # Having -d in PERL5OPT would lead to a disaster...
2017 local $ENV{PERL5OPT} = $ENV{PERL5OPT} if $ENV{PERL5OPT};
2018 $ENV{PERL5OPT} =~ s/(?:^|(?<=\s))-d\b// if $ENV{PERL5OPT};
2019 $ENV{PERL5OPT} =~ s/(?:^|(?<=\s))-d\B/-/ if $ENV{PERL5OPT};
2020 print $OUT "Making PERL5OPT->`$ENV{PERL5OPT}'.\n" if $ENV{PERL5OPT};
2021 (my $name = $0) =~ s,^.*[/\\],,s;
2022 if ( pipe $in1, $out1 and pipe $in2, $out2 and
2023 # system P_SESSION will fail if there is another process
04e43a21 2024 # in the same session with a "dependent" asynchronous child session.
2025 (($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 2026use Term::ReadKey;
2027use OS2::Process;
2028
2029my $in = shift; # Read from here and pass through
2030set_title pop;
2031system P_NOWAIT, $^X, '-we', <<EOS or die "Cannot start a grandkid";
2032 open IN, '<&=$in' or die "open <&=$in: \$!";
2033 \$| = 1; print while sysread IN, \$_, 1<<16;
2034EOS
2035
2036my $out = shift;
2037open OUT, ">&=$out" or die "Cannot open &=$out for writing: $!";
2038select OUT; $| = 1;
2039ReadMode 4; # Nodelay on kbd. Pipe is automatically nodelay...
2040print while sysread STDIN, $_, 1<<16;
2041ES
2042 and close $in1 and close $out2 ) {
2043 $pidprompt = ''; # Shown anyway in titlebar
2044 reset_IN_OUT($in2, $out1);
2045 $tty = '*reset*';
2046 return ''; # Indicate that reset_IN_OUT is called
2047 }
2048 return;
2049}
2050
2051sub create_IN_OUT { # Create a window with IN/OUT handles redirected there
2052 my $in = &get_fork_TTY if defined &get_fork_TTY;
2053 $in = $fork_TTY if defined $fork_TTY; # Backward compatibility
2054 if (not defined $in) {
2055 my $why = shift;
2056 print_help(<<EOP) if $why == 1;
2057I<#########> Forked, but do not know how to create a new B<TTY>. I<#########>
2058EOP
2059 print_help(<<EOP) if $why == 2;
2060I<#########> Daughter session, do not know how to change a B<TTY>. I<#########>
04e43a21 2061 This may be an asynchronous session, so the parent debugger may be active.
f1583d8f 2062EOP
2063 print_help(<<EOP) if $why != 4;
2064 Since two debuggers fight for the same TTY, input is severely entangled.
2065
2066EOP
405ff068 2067 print_help(<<EOP);
f1583d8f 2068 I know how to switch the output to a different window in xterms
2069 and OS/2 consoles only. For a manual switch, put the name of the created I<TTY>
2070 in B<\$DB::fork_TTY>, or define a function B<DB::get_fork_TTY()> returning this.
2071
405ff068 2072 On I<UNIX>-like systems one can get the name of a I<TTY> for the given window
2073 by typing B<tty>, and disconnect the I<shell> from I<TTY> by B<sleep 1000000>.
f1583d8f 2074
405ff068 2075EOP
f1583d8f 2076 } elsif ($in ne '') {
2077 TTY($in);
f36776d9 2078 }
f1583d8f 2079 undef $fork_TTY;
2080}
2081
2082sub resetterm { # We forked, so we need a different TTY
2083 my $in = shift;
2084 my $systemed = $in > 1 ? '-' : '';
2085 if ($pids) {
2086 $pids =~ s/\]/$systemed->$$]/;
2087 } else {
2088 $pids = "[$term_pid->$$]";
2089 }
2090 $pidprompt = $pids;
2091 $term_pid = $$;
2092 return unless $CreateTTY & $in;
2093 create_IN_OUT($in);
d338d6fe 2094}
2095
2096sub readline {
0c01eb4a 2097 local $.;
54d04a52 2098 if (@typeahead) {
2099 my $left = @typeahead;
2100 my $got = shift @typeahead;
2101 print $OUT "auto(-$left)", shift, $got, "\n";
2102 $term->AddHistory($got)
2103 if length($got) > 1 and defined $term->Features->{addHistory};
2104 return $got;
2105 }
d338d6fe 2106 local $frame = 0;
ee971a18 2107 local $doret = -2;
363b4d59 2108 if (ref $OUT and UNIVERSAL::isa($OUT, 'IO::Socket::INET')) {
e4e99f0d 2109 $OUT->write(join('', @_));
363b4d59 2110 my $stuff;
055fd3a9 2111 $IN->recv( $stuff, 2048 ); # XXX: what's wrong with sysread?
363b4d59 2112 $stuff;
2113 }
2114 else {
2115 $term->readline(@_);
2116 }
d338d6fe 2117}
2118
2119sub dump_option {
2120 my ($opt, $val)= @_;
55497cff 2121 $val = option_val($opt,'N/A');
2122 $val =~ s/([\\\'])/\\$1/g;
2123 printf $OUT "%20s = '%s'\n", $opt, $val;
2124}
2125
2126sub option_val {
2127 my ($opt, $default)= @_;
2128 my $val;
d338d6fe 2129 if (defined $optionVars{$opt}
055fd3a9 2130 and defined ${$optionVars{$opt}}) {
2131 $val = ${$optionVars{$opt}};
d338d6fe 2132 } elsif (defined $optionAction{$opt}
2133 and defined &{$optionAction{$opt}}) {
2134 $val = &{$optionAction{$opt}}();
2135 } elsif (defined $optionAction{$opt}
2136 and not defined $option{$opt}
2137 or defined $optionVars{$opt}
055fd3a9 2138 and not defined ${$optionVars{$opt}}) {
55497cff 2139 $val = $default;
d338d6fe 2140 } else {
2141 $val = $option{$opt};
2142 }
600d99fa 2143 $val = $default unless defined $val;
55497cff 2144 $val
d338d6fe 2145}
2146
2147sub parse_options {
2148 local($_)= @_;
055fd3a9 2149 # too dangerous to let intuitive usage overwrite important things
2150 # defaultion should never be the default
2151 my %opt_needs_val = map { ( $_ => 1 ) } qw{
6f891d7d 2152 arrayDepth hashDepth LineInfo maxTraceLen ornaments windowSize
055fd3a9 2153 pager quote ReadLine recallCommand RemotePort ShellBang TTY
2154 };
2155 while (length) {
2156 my $val_defaulted;
2157 s/^\s+// && next;
2158 s/^(\w+)(\W?)// or print($OUT "Invalid option `$_'\n"), last;
d338d6fe 2159 my ($opt,$sep) = ($1,$2);
2160 my $val;
2161 if ("?" eq $sep) {
2162 print($OUT "Option query `$opt?' followed by non-space `$_'\n"), last
2163 if /^\S/;
2164 #&dump_option($opt);
2165 } elsif ($sep !~ /\S/) {
055fd3a9 2166 $val_defaulted = 1;
2167 $val = "1"; # this is an evil default; make 'em set it!
d338d6fe 2168 } elsif ($sep eq "=") {
055fd3a9 2169
2170 if (s/ (["']) ( (?: \\. | (?! \1 ) [^\\] )* ) \1 //x) {
2171 my $quote = $1;
2172 ($val = $2) =~ s/\\([$quote\\])/$1/g;
2173 } else {
2174 s/^(\S*)//;
d338d6fe 2175 $val = $1;
055fd3a9 2176 print OUT qq(Option better cleared using $opt=""\n)
2177 unless length $val;
2178 }
2179
d338d6fe 2180 } else { #{ to "let some poor schmuck bounce on the % key in B<vi>."
2181 my ($end) = "\\" . substr( ")]>}$sep", index("([<{",$sep), 1 ); #}
2182 s/^(([^\\$end]|\\[\\$end])*)$end($|\s+)// or
2183 print($OUT "Unclosed option value `$opt$sep$_'\n"), last;
055fd3a9 2184 ($val = $1) =~ s/\\([\\$end])/$1/g;
d338d6fe 2185 }
055fd3a9 2186
2187 my $option;
2188 my $matches = grep( /^\Q$opt/ && ($option = $_), @options )
2189 || grep( /^\Q$opt/i && ($option = $_), @options );
2190
2191 print($OUT "Unknown option `$opt'\n"), next unless $matches;
2192 print($OUT "Ambiguous option `$opt'\n"), next if $matches > 1;
2193
2194 if ($opt_needs_val{$option} && $val_defaulted) {
2195 print $OUT "Option `$opt' is non-boolean. Use `O $option=VAL' to set, `O $option?' to query\n";
2196 next;
2197 }
2198
2199 $option{$option} = $val if defined $val;
2200
2201 eval qq{
2202 local \$frame = 0;
2203 local \$doret = -2;
2204 require '$optionRequire{$option}';
2205 1;
2206 } || die # XXX: shouldn't happen
2207 if defined $optionRequire{$option} &&
2208 defined $val;
2209
2210 ${$optionVars{$option}} = $val
2211 if defined $optionVars{$option} &&
2212 defined $val;
2213
2214 &{$optionAction{$option}} ($val)
2215 if defined $optionAction{$option} &&
2216 defined &{$optionAction{$option}} &&
2217 defined $val;
2218
2219 # Not $rcfile
2220 dump_option($option) unless $OUT eq \*STDERR;
d338d6fe 2221 }
2222}
2223
54d04a52 2224sub set_list {
2225 my ($stem,@list) = @_;
2226 my $val;
055fd3a9 2227 $ENV{"${stem}_n"} = @list;
54d04a52 2228 for $i (0 .. $#list) {
2229 $val = $list[$i];
2230 $val =~ s/\\/\\\\/g;
ee971a18 2231 $val =~ s/([\0-\37\177\200-\377])/"\\0x" . unpack('H2',$1)/eg;
055fd3a9 2232 $ENV{"${stem}_$i"} = $val;
54d04a52 2233 }
2234}
2235
2236sub get_list {
2237 my $stem = shift;
2238 my @list;
055fd3a9 2239 my $n = delete $ENV{"${stem}_n"};
54d04a52 2240 my $val;
2241 for $i (0 .. $n - 1) {
055fd3a9 2242 $val = delete $ENV{"${stem}_$i"};
54d04a52 2243 $val =~ s/\\((\\)|0x(..))/ $2 ? $2 : pack('H2', $3) /ge;
2244 push @list, $val;
2245 }
2246 @list;
2247}
2248
d338d6fe 2249sub catch {
2250 $signal = 1;
4639966b 2251 return; # Put nothing on the stack - malloc/free land!
d338d6fe 2252}
2253
2254sub warn {
2255 my($msg)= join("",@_);
2256 $msg .= ": $!\n" unless $msg =~ /\n$/;
2257 print $OUT $msg;
2258}
2259
f1583d8f 2260sub reset_IN_OUT {
2261 my $switch_li = $LINEINFO eq $OUT;
2262 if ($term and $term->Features->{newTTY}) {
2263 ($IN, $OUT) = (shift, shift);
2264 $term->newTTY($IN, $OUT);
2265 } elsif ($term) {
2266 &warn("Too late to set IN/OUT filehandles, enabled on next `R'!\n");
2267 } else {
2268 ($IN, $OUT) = (shift, shift);
2269 }
2270 my $o = select $OUT;
2271 $| = 1;
2272 select $o;
2273 $LINEINFO = $OUT if $switch_li;
2274}
2275
d338d6fe 2276sub TTY {
f36776d9 2277 if (@_ and $term and $term->Features->{newTTY}) {
2278 my ($in, $out) = shift;
2279 if ($in =~ /,/) {
2280 ($in, $out) = split /,/, $in, 2;
2281 } else {
2282 $out = $in;
2283 }
2284 open IN, $in or die "cannot open `$in' for read: $!";
2285 open OUT, ">$out" or die "cannot open `$out' for write: $!";
f1583d8f 2286 reset_IN_OUT(\*IN,\*OUT);
f36776d9 2287 return $tty = $in;
f1583d8f 2288 }
2289 &warn("Too late to set TTY, enabled on next `R'!\n") if $term and @_;
2290 # Useful if done through PERLDB_OPTS:
43aed9ee 2291 $tty = shift if @_;
d338d6fe 2292 $tty or $console;
2293}
2294
2295sub noTTY {
2296 if ($term) {
43aed9ee 2297 &warn("Too late to set noTTY, enabled on next `R'!\n") if @_;
d338d6fe 2298 }
43aed9ee 2299 $notty = shift if @_;
d338d6fe 2300 $notty;
2301}
2302
2303sub ReadLine {
2304 if ($term) {
43aed9ee 2305 &warn("Too late to set ReadLine, enabled on next `R'!\n") if @_;
d338d6fe 2306 }
43aed9ee 2307 $rl = shift if @_;
d338d6fe 2308 $rl;
2309}
2310
363b4d59 2311sub RemotePort {
2312 if ($term) {
2313 &warn("Too late to set RemotePort, enabled on next 'R'!\n") if @_;
2314 }
2315 $remoteport = shift if @_;
2316 $remoteport;
2317}
2318
a737e074 2319sub tkRunning {
055fd3a9 2320 if (${$term->Features}{tkRunning}) {
a737e074 2321 return $term->tkRunning(@_);
2322 } else {
2323 print $OUT "tkRunning not supported by current ReadLine package.\n";
2324 0;
2325 }
2326}
2327
d338d6fe 2328sub NonStop {
2329 if ($term) {
43aed9ee 2330 &warn("Too late to set up NonStop mode, enabled on next `R'!\n") if @_;
d338d6fe 2331 }
43aed9ee 2332 $runnonstop = shift if @_;
d338d6fe 2333 $runnonstop;
2334}
2335
2336sub pager {
2337 if (@_) {
2338 $pager = shift;
2339 $pager="|".$pager unless $pager =~ /^(\+?\>|\|)/;
2340 }
2341 $pager;
2342}
2343
2344sub shellBang {
2345 if (@_) {
2346 $sh = quotemeta shift;
2347 $sh .= "\\b" if $sh =~ /\w$/;
2348 }
2349 $psh = $sh;
2350 $psh =~ s/\\b$//;
2351 $psh =~ s/\\(.)/$1/g;
d338d6fe 2352 $psh;
2353}
2354
7a2e2cd6 2355sub ornaments {
2356 if (defined $term) {
2357 local ($warnLevel,$dieLevel) = (0, 1);
2358 return '' unless $term->Features->{ornaments};
2359 eval { $term->ornaments(@_) } || '';
2360 } else {
2361 $ornaments = shift;
2362 }
2363}
2364
d338d6fe 2365sub recallCommand {
2366 if (@_) {
2367 $rc = quotemeta shift;
2368 $rc .= "\\b" if $rc =~ /\w$/;
2369 }
2370 $prc = $rc;
2371 $prc =~ s/\\b$//;
2372 $prc =~ s/\\(.)/$1/g;
d338d6fe 2373 $prc;
2374}
2375
2376sub LineInfo {
2377 return $lineinfo unless @_;
2378 $lineinfo = shift;
2379 my $stream = ($lineinfo =~ /^(\+?\>|\|)/) ? $lineinfo : ">$lineinfo";
055fd3a9 2380 $slave_editor = ($stream =~ /^\|/);
d338d6fe 2381 open(LINEINFO, "$stream") || &warn("Cannot open `$stream' for write");
2382 $LINEINFO = \*LINEINFO;
2383 my $save = select($LINEINFO);
2384 $| = 1;
2385 select($save);
2386 $lineinfo;
2387}
2388
ee971a18 2389sub list_versions {
2390 my %version;
2391 my $file;
2392 for (keys %INC) {
2393 $file = $_;
2394 s,\.p[lm]$,,i ;
2395 s,/,::,g ;
2396 s/^perl5db$/DB/;
55497cff 2397 s/^Term::ReadLine::readline$/readline/;
055fd3a9 2398 if (defined ${ $_ . '::VERSION' }) {
2399 $version{$file} = "${ $_ . '::VERSION' } from ";
ee971a18 2400 }
2401 $version{$file} .= $INC{$file};
2402 }
2c53b6d0 2403 dumpit($OUT,\%version);
ee971a18 2404}
2405
d338d6fe 2406sub sethelp {
04e43a21 2407 # XXX: make sure there are tabs between the command and explanation,
055fd3a9 2408 # or print_help will screw up your formatting if you have
2409 # eeevil ornaments enabled. This is an insane mess.
2410
d338d6fe 2411 $help = "
6027b9a3 2412B<T> Stack trace.
2413B<s> [I<expr>] Single step [in I<expr>].
2414B<n> [I<expr>] Next, steps over subroutine calls [in I<expr>].
2415<B<CR>> Repeat last B<n> or B<s> command.
2416B<r> Return from current subroutine.
2417B<c> [I<line>|I<sub>] Continue; optionally inserts a one-time-only breakpoint
55497cff 2418 at the specified position.
6027b9a3 2419B<l> I<min>B<+>I<incr> List I<incr>+1 lines starting at I<min>.
2420B<l> I<min>B<->I<max> List lines I<min> through I<max>.
2421B<l> I<line> List single I<line>.
2422B<l> I<subname> List first window of lines from subroutine.
3fbd6552 2423B<l> I<\$var> List first window of lines from subroutine referenced by I<\$var>.
6027b9a3 2424B<l> List next window of lines.
2425B<-> List previous window of lines.
2426B<w> [I<line>] List window around I<line>.
2427B<.> Return to the executed line.
bee32ff8 2428B<f> I<filename> Switch to viewing I<filename>. File must be already loaded.
2429 I<filename> may be either the full name of the file, or a regular
2430 expression matching the full file name:
2431 B<f> I</home/me/foo.pl> and B<f> I<oo\\.> may access the same file.
2432 Evals (with saved bodies) are considered to be filenames:
2433 B<f> I<(eval 7)> and B<f> I<eval 7\\b> access the body of the 7th eval
2434 (in the order of execution).
6027b9a3 2435B</>I<pattern>B</> Search forwards for I<pattern>; final B</> is optional.
2436B<?>I<pattern>B<?> Search backwards for I<pattern>; final B<?> is optional.
2437B<L> List all breakpoints and actions.
2438B<S> [[B<!>]I<pattern>] List subroutine names [not] matching I<pattern>.
2439B<t> Toggle trace mode.
2440B<t> I<expr> Trace through execution of I<expr>.
2441B<b> [I<line>] [I<condition>]
2442 Set breakpoint; I<line> defaults to the current execution line;
2443 I<condition> breaks if it evaluates to true, defaults to '1'.
2444B<b> I<subname> [I<condition>]
d338d6fe 2445 Set breakpoint at first line of subroutine.
3fbd6552 2446B<b> I<\$var> Set breakpoint at first line of subroutine referenced by I<\$var>.
6027b9a3 2447B<b> B<load> I<filename> Set breakpoint on `require'ing the given file.
2448B<b> B<postpone> I<subname> [I<condition>]
55497cff 2449 Set breakpoint at first line of subroutine after
2450 it is compiled.
6027b9a3 2451B<b> B<compile> I<subname>
1d06cb2d 2452 Stop after the subroutine is compiled.
6027b9a3 2453B<d> [I<line>] Delete the breakpoint for I<line>.
2454B<D> Delete all breakpoints.
2455B<a> [I<line>] I<command>
3fbd6552 2456 Set an action to be done before the I<line> is executed;
2457 I<line> defaults to the current execution line.
6027b9a3 2458 Sequence is: check for breakpoint/watchpoint, print line
2459 if necessary, do action, prompt user if necessary,
3fbd6552 2460 execute line.
2461B<a> [I<line>] Delete the action for I<line>.
6027b9a3 2462B<A> Delete all actions.
2463B<W> I<expr> Add a global watch-expression.
2464B<W> Delete all watch-expressions.
2465B<V> [I<pkg> [I<vars>]] List some (default all) variables in package (default current).
2466 Use B<~>I<pattern> and B<!>I<pattern> for positive and negative regexps.
2467B<X> [I<vars>] Same as \"B<V> I<currentpackage> [I<vars>]\".
91e74348 2468B<x> I<expr> Evals expression in list context, dumps the result.
2469B<m> I<expr> Evals expression in list context, prints methods callable
1d06cb2d 2470 on the first element of the result.
6027b9a3 2471B<m> I<class> Prints methods callable via the given class.
055fd3a9 2472
2473B<<> ? List Perl commands to run before each prompt.
6027b9a3 2474B<<> I<expr> Define Perl command to run before each prompt.
2475B<<<> I<expr> Add to the list of Perl commands to run before each prompt.
055fd3a9 2476B<>> ? List Perl commands to run after each prompt.
6027b9a3 2477B<>> I<expr> Define Perl command to run after each prompt.
3fbd6552 2478B<>>B<>> I<expr> Add to the list of Perl commands to run after each prompt.
6027b9a3 2479B<{> I<db_command> Define debugger command to run before each prompt.
055fd3a9 2480B<{> ? List debugger commands to run before each prompt.
6027b9a3 2481B<{{> I<db_command> Add to the list of debugger commands to run before each prompt.
2482B<$prc> I<number> Redo a previous command (default previous command).
2483B<$prc> I<-number> Redo number'th-to-last command.
2484B<$prc> I<pattern> Redo last command that started with I<pattern>.
2485 See 'B<O> I<recallCommand>' too.
2486B<$psh$psh> I<cmd> Run cmd in a subprocess (reads from DB::IN, writes to DB::OUT)"
d338d6fe 2487 . ( $rc eq $sh ? "" : "
6027b9a3 2488B<$psh> [I<cmd>] Run I<cmd> in subshell (forces \"\$SHELL -c 'cmd'\")." ) . "
2489 See 'B<O> I<shellBang>' too.
2490B<H> I<-number> Display last number commands (default all).
2491B<p> I<expr> Same as \"I<print {DB::OUT} expr>\" in current package.
2492B<|>I<dbcmd> Run debugger command, piping DB::OUT to current pager.
2493B<||>I<dbcmd> Same as B<|>I<dbcmd> but DB::OUT is temporarilly select()ed as well.
2494B<\=> [I<alias> I<value>] Define a command alias, or list current aliases.
2495I<command> Execute as a perl statement in current package.
2496B<v> Show versions of loaded modules.
2497B<R> Pure-man-restart of debugger, some of debugger state
55497cff 2498 and command-line options may be lost.
04e43a21 2499 Currently the following settings are preserved:
6027b9a3 2500 history, breakpoints and actions, debugger B<O>ptions
2501 and the following command-line options: I<-w>, I<-I>, I<-e>.
055fd3a9 2502
2503B<O> [I<opt>] ... Set boolean option to true
2504B<O> [I<opt>B<?>] Query options
2505B<O> [I<opt>B<=>I<val>] [I<opt>=B<\">I<val>B<\">] ...
2506 Set options. Use quotes in spaces in value.
2507 I<recallCommand>, I<ShellBang> chars used to recall command or spawn shell;
2508 I<pager> program for output of \"|cmd\";
2509 I<tkRunning> run Tk while prompting (with ReadLine);
2510 I<signalLevel> I<warnLevel> I<dieLevel> level of verbosity;
2511 I<inhibit_exit> Allows stepping off the end of the script.
2512 I<ImmediateStop> Debugger should stop as early as possible.
2513 I<RemotePort> Remote hostname:port for remote debugging
2514 The following options affect what happens with B<V>, B<X>, and B<x> commands:
2515 I<arrayDepth>, I<hashDepth> print only first N elements ('' for all);
2516 I<compactDump>, I<veryCompact> change style of array and hash dump;
2517 I<globPrint> whether to print contents of globs;
2518 I<DumpDBFiles> dump arrays holding debugged files;
2519 I<DumpPackages> dump symbol tables of packages;
2520 I<DumpReused> dump contents of \"reused\" addresses;
2521 I<quote>, I<HighBit>, I<undefPrint> change style of string dump;
2522 I<bareStringify> Do not print the overload-stringified value;
2523 Other options include:
2524 I<PrintRet> affects printing of return value after B<r> command,
04e43a21 2525 I<frame> affects printing messages on subroutine entry/exit.
2526 I<AutoTrace> affects printing messages on possible breaking points.
2527 I<maxTraceLen> gives max length of evals/args listed in stack trace.
055fd3a9 2528 I<ornaments> affects screen appearance of the command line.
f1583d8f 2529 I<CreateTTY> bits control attempts to create a new TTY on events:
2530 1: on fork() 2: debugger is started inside debugger
2531 4: on startup
055fd3a9 2532 During startup options are initialized from \$ENV{PERLDB_OPTS}.
2533 You can put additional initialization options I<TTY>, I<noTTY>,
2534 I<ReadLine>, I<NonStop>, and I<RemotePort> there (or use
2535 `B<R>' after you set them).
2536
2537B<q> or B<^D> Quit. Set B<\$DB::finished = 0> to debug global destruction.
6027b9a3 2538B<h> [I<db_command>] Get help [on a specific debugger command], enter B<|h> to page.
2539B<h h> Summary of debugger commands.
055fd3a9 2540B<$doccmd> I<manpage> Runs the external doc viewer B<$doccmd> command on the
2541 named Perl I<manpage>, or on B<$doccmd> itself if omitted.
2542 Set B<\$DB::doccmd> to change viewer.
2543
2544Type `|h' for a paged display if this was too hard to read.
2545
04e43a21 2546"; # Fix balance of vi % matching: }}}}
d338d6fe 2547
c391288e 2548 # note: tabs in the following section are not-so-helpful
d338d6fe 2549 $summary = <<"END_SUM";
6027b9a3 2550I<List/search source lines:> I<Control script execution:>
2551 B<l> [I<ln>|I<sub>] List source code B<T> Stack trace
2552 B<-> or B<.> List previous/current line B<s> [I<expr>] Single step [in expr]
2553 B<w> [I<line>] List around line B<n> [I<expr>] Next, steps over subs
d9f67849 2554 B<f> I<filename> View source in file <B<CR>/B<Enter>> Repeat last B<n> or B<s>
6027b9a3 2555 B</>I<pattern>B</> B<?>I<patt>B<?> Search forw/backw B<r> Return from subroutine
c391288e 2556 B<v> Show versions of modules B<c> [I<ln>|I<sub>] Continue until position
6027b9a3 2557I<Debugger controls:> B<L> List break/watch/actions
2558 B<O> [...] Set debugger options B<t> [I<expr>] Toggle trace [trace expr]
d9f67849 2559 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 2560 B<$prc> [I<N>|I<pat>] Redo a previous command B<d> [I<ln>] or B<D> Delete a/all breakpoints
2561 B<H> [I<-num>] Display last num commands B<a> [I<ln>] I<cmd> Do cmd before line
2562 B<=> [I<a> I<val>] Define/list an alias B<W> I<expr> Add a watch expression
2563 B<h> [I<db_cmd>] Get help on command B<A> or B<W> Delete all actions/watch
d9f67849 2564 B<|>[B<|>]I<db_cmd> Send output to pager B<$psh>\[B<$psh>\] I<syscmd> Run cmd in a subprocess
c391288e 2565 B<q> or B<^D> Quit B<R> Attempt a restart
2566I<Data Examination:> B<expr> Execute perl code, also see: B<s>,B<n>,B<t> I<expr>
2567 B<x>|B<m> I<expr> Evals expr in list context, dumps the result or lists methods.
2568 B<p> I<expr> Print expression (uses script's current package).
2569 B<S> [[B<!>]I<pat>] List subroutine names [not] matching pattern
2570 B<V> [I<Pk> [I<Vars>]] List Variables in Package. Vars can be ~pattern or !pattern.
2571 B<X> [I<Vars>] Same as \"B<V> I<current_package> [I<Vars>]\".
055fd3a9 2572For more help, type B<h> I<cmd_letter>, or run B<$doccmd perldebug> for all docs.
d338d6fe 2573END_SUM
055fd3a9 2574 # ')}}; # Fix balance of vi % matching
d338d6fe 2575}
2576
6027b9a3 2577sub print_help {
055fd3a9 2578 local $_ = shift;
2579
2580 # Restore proper alignment destroyed by eeevil I<> and B<>
2581 # ornaments: A pox on both their houses!
2582 #
2583 # A help command will have everything up to and including
04e43a21 2584 # the first tab sequence padded into a field 16 (or if indented 20)
2585 # wide. If it's wider than that, an extra space will be added.
055fd3a9 2586 s{
2587 ^ # only matters at start of line
2588 ( \040{4} | \t )* # some subcommands are indented
2589 ( < ? # so <CR> works
2590 [BI] < [^\t\n] + ) # find an eeevil ornament
2591 ( \t+ ) # original separation, discarded
2592 ( .* ) # this will now start (no earlier) than
2593 # column 16
2594 } {
2595 my($leadwhite, $command, $midwhite, $text) = ($1, $2, $3, $4);
2596 my $clean = $command;
2597 $clean =~ s/[BI]<([^>]*)>/$1/g;
2598 # replace with this whole string:
04e43a21 2599 ($leadwhite ? " " x 4 : "")
055fd3a9 2600 . $command
04e43a21 2601 . ((" " x (16 + ($leadwhite ? 4 : 0) - length($clean))) || " ")
055fd3a9 2602 . $text;
2603
2604 }mgex;
2605
2606 s{ # handle bold ornaments
2607 B < ( [^>] + | > ) >
2608 } {
2609 $Term::ReadLine::TermCap::rl_term_set[2]
2610 . $1
2611 . $Term::ReadLine::TermCap::rl_term_set[3]
2612 }gex;
2613
2614 s{ # handle italic ornaments
2615 I < ( [^>] + | > ) >
2616 } {
2617 $Term::ReadLine::TermCap::rl_term_set[0]
2618 . $1
2619 . $Term::ReadLine::TermCap::rl_term_set[1]
2620 }gex;
2621
2622 print $OUT $_;
2623}
2624
2625sub fix_less {
2626 return if defined $ENV{LESS} && $ENV{LESS} =~ /r/;
2627 my $is_less = $pager =~ /\bless\b/;
2628 if ($pager =~ /\bmore\b/) {
2629 my @st_more = stat('/usr/bin/more');
2630 my @st_less = stat('/usr/bin/less');
2631 $is_less = @st_more && @st_less
2632 && $st_more[0] == $st_less[0]
2633 && $st_more[1] == $st_less[1];
2634 }
2635 # changes environment!
2636 $ENV{LESS} .= 'r' if $is_less;
6027b9a3 2637}
2638
d338d6fe 2639sub diesignal {
54d04a52 2640 local $frame = 0;
ee971a18 2641 local $doret = -2;
77fb7b16 2642 $SIG{'ABRT'} = 'DEFAULT';
d338d6fe 2643 kill 'ABRT', $$ if $panic++;
ee85b803 2644 if (defined &Carp::longmess) {
2645 local $SIG{__WARN__} = '';
2646 local $Carp::CarpLevel = 2; # mydie + confess
2647 &warn(Carp::longmess("Signal @_"));
2648 }
2649 else {
2650 print $DB::OUT "Got signal @_\n";
2651 }
d338d6fe 2652 kill 'ABRT', $$;
2653}
2654
2655sub dbwarn {
54d04a52 2656 local $frame = 0;
ee971a18 2657 local $doret = -2;
d338d6fe 2658 local $SIG{__WARN__} = '';
77fb7b16 2659 local $SIG{__DIE__} = '';
fb73857a 2660 eval { require Carp } if defined $^S; # If error/warning during compilation,
2661 # require may be broken.
04e43a21 2662 CORE::warn(@_, "\nCannot print stack trace, load with -MCarp option to see stack"),
fb73857a 2663 return unless defined &Carp::longmess;
d338d6fe 2664 my ($mysingle,$mytrace) = ($single,$trace);
2665 $single = 0; $trace = 0;
2666 my $mess = Carp::longmess(@_);
2667 ($single,$trace) = ($mysingle,$mytrace);
d338d6fe 2668 &warn($mess);
d338d6fe 2669}
2670
2671sub dbdie {
54d04a52 2672 local $frame = 0;
ee971a18 2673 local $doret = -2;
d338d6fe 2674 local $SIG{__DIE__} = '';
2675 local $SIG{__WARN__} = '';
2676 my $i = 0; my $ineval = 0; my $sub;
fb73857a 2677 if ($dieLevel > 2) {
d338d6fe 2678 local $SIG{__WARN__} = \&dbwarn;
fb73857a 2679 &warn(@_); # Yell no matter what
2680 return;
2681 }
2682 if ($dieLevel < 2) {
2683 die @_ if $^S; # in eval propagate
d338d6fe 2684 }
98ea0861 2685 # No need to check $^S, eval is much more robust nowadays
2686 eval { require Carp }; #if defined $^S;# If error/warning during compilation,
fb73857a 2687 # require may be broken.
055fd3a9 2688
fb73857a 2689 die(@_, "\nCannot print stack trace, load with -MCarp option to see stack")
2690 unless defined &Carp::longmess;
055fd3a9 2691
d338d6fe 2692 # We do not want to debug this chunk (automatic disabling works
2693 # inside DB::DB, but not in Carp).
2694 my ($mysingle,$mytrace) = ($single,$trace);
2695 $single = 0; $trace = 0;
98ea0861 2696 my $mess = "@_";
2697 {
2698 package Carp; # Do not include us in the list
2699 eval {
2700 $mess = Carp::longmess(@_);
2701 };
2702 }
d338d6fe 2703 ($single,$trace) = ($mysingle,$mytrace);
d338d6fe 2704 die $mess;
2705}
2706
d338d6fe 2707sub warnLevel {
2708 if (@_) {
2709 $prevwarn = $SIG{__WARN__} unless $warnLevel;
2710 $warnLevel = shift;
2711 if ($warnLevel) {
0b7ed949 2712 $SIG{__WARN__} = \&DB::dbwarn;
04e43a21 2713 } elsif ($prevwarn) {
d338d6fe 2714 $SIG{__WARN__} = $prevwarn;
2715 }
2716 }
2717 $warnLevel;
2718}
2719
2720sub dieLevel {
2721 if (@_) {
2722 $prevdie = $SIG{__DIE__} unless $dieLevel;
2723 $dieLevel = shift;
2724 if ($dieLevel) {
0b7ed949 2725 $SIG{__DIE__} = \&DB::dbdie; # if $dieLevel < 2;
2726 #$SIG{__DIE__} = \&DB::diehard if $dieLevel >= 2;
d338d6fe 2727 print $OUT "Stack dump during die enabled",
43aed9ee 2728 ( $dieLevel == 1 ? " outside of evals" : ""), ".\n"
2729 if $I_m_init;
d338d6fe 2730 print $OUT "Dump printed too.\n" if $dieLevel > 2;
04e43a21 2731 } elsif ($prevdie) {
d338d6fe 2732 $SIG{__DIE__} = $prevdie;
2733 print $OUT "Default die handler restored.\n";
2734 }
2735 }
2736 $dieLevel;
2737}
2738
2739sub signalLevel {
2740 if (@_) {
2741 $prevsegv = $SIG{SEGV} unless $signalLevel;
2742 $prevbus = $SIG{BUS} unless $signalLevel;
2743 $signalLevel = shift;
2744 if ($signalLevel) {
77fb7b16 2745 $SIG{SEGV} = \&DB::diesignal;
2746 $SIG{BUS} = \&DB::diesignal;
d338d6fe 2747 } else {
2748 $SIG{SEGV} = $prevsegv;
2749 $SIG{BUS} = $prevbus;
2750 }
2751 }
2752 $signalLevel;
2753}
2754
83ee9e09 2755sub CvGV_name {
2756 my $in = shift;
2757 my $name = CvGV_name_or_bust($in);
2758 defined $name ? $name : $in;
2759}
2760
2761sub CvGV_name_or_bust {
2762 my $in = shift;
2763 return if $skipCvGV; # Backdoor to avoid problems if XS broken...
2526eab8 2764 return unless ref $in;
83ee9e09 2765 $in = \&$in; # Hard reference...
2766 eval {require Devel::Peek; 1} or return;
2767 my $gv = Devel::Peek::CvGV($in) or return;
2768 *$gv{PACKAGE} . '::' . *$gv{NAME};
2769}
2770
1d06cb2d 2771sub find_sub {
2772 my $subr = shift;
1d06cb2d 2773 $sub{$subr} or do {
83ee9e09 2774 return unless defined &$subr;
2775 my $name = CvGV_name_or_bust($subr);
2776 my $data;
2777 $data = $sub{$name} if defined $name;
2778 return $data if defined $data;
2779
2780 # Old stupid way...
1d06cb2d 2781 $subr = \&$subr; # Hard reference
2782 my $s;
2783 for (keys %sub) {
2784 $s = $_, last if $subr eq \&$_;
2785 }
2786 $sub{$s} if $s;
2787 }
2788}
2789
2790sub methods {
2791 my $class = shift;
2792 $class = ref $class if ref $class;
2793 local %seen;
2794 local %packs;
2795 methods_via($class, '', 1);
2796 methods_via('UNIVERSAL', 'UNIVERSAL', 0);
2797}
2798
2799sub methods_via {
2800 my $class = shift;
2801 return if $packs{$class}++;
2802 my $prefix = shift;
2803 my $prepend = $prefix ? "via $prefix: " : '';
2804 my $name;
055fd3a9 2805 for $name (grep {defined &{${"${class}::"}{$_}}}
2806 sort keys %{"${class}::"}) {
477ea2b1 2807 next if $seen{ $name }++;
1d06cb2d 2808 print $DB::OUT "$prepend$name\n";
2809 }
2810 return unless shift; # Recurse?
055fd3a9 2811 for $name (@{"${class}::ISA"}) {
1d06cb2d 2812 $prepend = $prefix ? $prefix . " -> $name" : $name;
2813 methods_via($name, $prepend, 1);
2814 }
2815}
2816
055fd3a9 2817sub setman {
2986a63f 2818 $doccmd = $^O !~ /^(?:MSWin32|VMS|os2|dos|amigaos|riscos|MacOS|NetWare)\z/s
055fd3a9 2819 ? "man" # O Happy Day!
2820 : "perldoc"; # Alas, poor unfortunates
2821}
2822
2823sub runman {
2824 my $page = shift;
2825 unless ($page) {
2826 &system("$doccmd $doccmd");
2827 return;
2828 }
2829 # this way user can override, like with $doccmd="man -Mwhatever"
2830 # or even just "man " to disable the path check.
2831 unless ($doccmd eq 'man') {
2832 &system("$doccmd $page");
2833 return;
2834 }
2835
2836 $page = 'perl' if lc($page) eq 'help';
2837
2838 require Config;
2839 my $man1dir = $Config::Config{'man1dir'};
2840 my $man3dir = $Config::Config{'man3dir'};
2841 for ($man1dir, $man3dir) { s#/[^/]*\z## if /\S/ }
2842 my $manpath = '';
2843 $manpath .= "$man1dir:" if $man1dir =~ /\S/;
2844 $manpath .= "$man3dir:" if $man3dir =~ /\S/ && $man1dir ne $man3dir;
2845 chop $manpath if $manpath;
2846 # harmless if missing, I figure
2847 my $oldpath = $ENV{MANPATH};
2848 $ENV{MANPATH} = $manpath if $manpath;
2849 my $nopathopt = $^O =~ /dunno what goes here/;
04e43a21 2850 if (CORE::system($doccmd,
055fd3a9 2851 # I just *know* there are men without -M
2852 (($manpath && !$nopathopt) ? ("-M", $manpath) : ()),
2853 split ' ', $page) )
2854 {
2855 unless ($page =~ /^perl\w/) {
2856 if (grep { $page eq $_ } qw{
2857 5004delta 5005delta amiga api apio book boot bot call compile
2858 cygwin data dbmfilter debug debguts delta diag doc dos dsc embed
2859 faq faq1 faq2 faq3 faq4 faq5 faq6 faq7 faq8 faq9 filter fork
2860 form func guts hack hist hpux intern ipc lexwarn locale lol mod
2861 modinstall modlib number obj op opentut os2 os390 pod port
2862 ref reftut run sec style sub syn thrtut tie toc todo toot tootc
2863 trap unicode var vms win32 xs xstut
2864 })
2865 {
2866 $page =~ s/^/perl/;
04e43a21 2867 CORE::system($doccmd,
055fd3a9 2868 (($manpath && !$nopathopt) ? ("-M", $manpath) : ()),
2869 $page);
2870 }
2871 }
2872 }
2873 if (defined $oldpath) {
2874 $ENV{MANPATH} = $manpath;
2875 } else {
2876 delete $ENV{MANPATH};
2877 }
2878}
2879
d338d6fe 2880# The following BEGIN is very handy if debugger goes havoc, debugging debugger?
2881
2882BEGIN { # This does not compile, alas.
2883 $IN = \*STDIN; # For bugs before DB::OUT has been opened
2884 $OUT = \*STDERR; # For errors before DB::OUT has been opened
2885 $sh = '!';
2886 $rc = ',';
2887 @hist = ('?');
2888 $deep = 100; # warning if stack gets this deep
2889 $window = 10;
2890 $preview = 3;
2891 $sub = '';
77fb7b16 2892 $SIG{INT} = \&DB::catch;
ee971a18 2893 # This may be enabled to debug debugger:
2894 #$warnLevel = 1 unless defined $warnLevel;
2895 #$dieLevel = 1 unless defined $dieLevel;
2896 #$signalLevel = 1 unless defined $signalLevel;
d338d6fe 2897
2898 $db_stop = 0; # Compiler warning
2899 $db_stop = 1 << 30;
2900 $level = 0; # Level of recursive debugging
55497cff 2901 # @stack and $doret are needed in sub sub, which is called for DB::postponed.
2902 # Triggers bug (?) in perl is we postpone this until runtime:
2903 @postponed = @stack = (0);
f8b5b99c 2904 $stack_depth = 0; # Localized $#stack
55497cff 2905 $doret = -2;
2906 $frame = 0;
d338d6fe 2907}
2908
54d04a52 2909BEGIN {$^W = $ini_warn;} # Switch warnings back
2910
04e43a21 2911#use Carp; # This did break, left for debugging
d338d6fe 2912
55497cff 2913sub db_complete {
08a4aec0 2914 # Specific code for b c l V m f O, &blah, $blah, @blah, %blah
55497cff 2915 my($text, $line, $start) = @_;
477ea2b1 2916 my ($itext, $search, $prefix, $pack) =
055fd3a9 2917 ($text, "^\Q${'package'}::\E([^:]+)\$");
55497cff 2918
08a4aec0 2919 return sort grep /^\Q$text/, (keys %sub), qw(postpone load compile), # subroutines
2920 (map { /$search/ ? ($1) : () } keys %sub)
2921 if (substr $line, 0, $start) =~ /^\|*[blc]\s+((postpone|compile)\s+)?$/;
2922 return sort grep /^\Q$text/, values %INC # files
477ea2b1 2923 if (substr $line, 0, $start) =~ /^\|*b\s+load\s+$/;
08a4aec0 2924 return sort map {($_, db_complete($_ . "::", "V ", 2))}
2925 grep /^\Q$text/, map { /^(.*)::$/ ? ($1) : ()} keys %:: # top-packages
2926 if (substr $line, 0, $start) =~ /^\|*[Vm]\s+$/ and $text =~ /^\w*$/;
2927 return sort map {($_, db_complete($_ . "::", "V ", 2))}
2928 grep !/^main::/,
2929 grep /^\Q$text/, map { /^(.*)::$/ ? ($prefix . "::$1") : ()} keys %{$prefix . '::'}
2930 # packages
2931 if (substr $line, 0, $start) =~ /^\|*[Vm]\s+$/
2932 and $text =~ /^(.*[^:])::?(\w*)$/ and $prefix = $1;
477ea2b1 2933 if ( $line =~ /^\|*f\s+(.*)/ ) { # Loaded files
2934 # We may want to complete to (eval 9), so $text may be wrong
2935 $prefix = length($1) - length($text);
2936 $text = $1;
08a4aec0 2937 return sort
2938 map {substr $_, 2 + $prefix} grep /^_<\Q$text/, (keys %main::), $0
477ea2b1 2939 }
55497cff 2940 if ((substr $text, 0, 1) eq '&') { # subroutines
2941 $text = substr $text, 1;
2942 $prefix = "&";
08a4aec0 2943 return sort map "$prefix$_",
2944 grep /^\Q$text/,
2945 (keys %sub),
2946 (map { /$search/ ? ($1) : () }
2947 keys %sub);
55497cff 2948 }
2949 if ($text =~ /^[\$@%](.*)::(.*)/) { # symbols in a package
2950 $pack = ($1 eq 'main' ? '' : $1) . '::';
2951 $prefix = (substr $text, 0, 1) . $1 . '::';
2952 $text = $2;
2953 my @out
2954 = map "$prefix$_", grep /^\Q$text/, grep /^_?[a-zA-Z]/, keys %$pack ;
2955 if (@out == 1 and $out[0] =~ /::$/ and $out[0] ne $itext) {
2956 return db_complete($out[0], $line, $start);
2957 }
08a4aec0 2958 return sort @out;
55497cff 2959 }
2960 if ($text =~ /^[\$@%]/) { # symbols (in $package + packages in main)
2961 $pack = ($package eq 'main' ? '' : $package) . '::';
2962 $prefix = substr $text, 0, 1;
2963 $text = substr $text, 1;
2964 my @out = map "$prefix$_", grep /^\Q$text/,
2965 (grep /^_?[a-zA-Z]/, keys %$pack),
2966 ( $pack eq '::' ? () : (grep /::$/, keys %::) ) ;
2967 if (@out == 1 and $out[0] =~ /::$/ and $out[0] ne $itext) {
2968 return db_complete($out[0], $line, $start);
2969 }
08a4aec0 2970 return sort @out;
55497cff 2971 }
477ea2b1 2972 if ((substr $line, 0, $start) =~ /^\|*O\b.*\s$/) { # Options after a space
55497cff 2973 my @out = grep /^\Q$text/, @options;
2974 my $val = option_val($out[0], undef);
2975 my $out = '? ';
2976 if (not defined $val or $val =~ /[\n\r]/) {
2977 # Can do nothing better
2978 } elsif ($val =~ /\s/) {
2979 my $found;
2980 foreach $l (split //, qq/\"\'\#\|/) {
2981 $out = "$l$val$l ", last if (index $val, $l) == -1;
2982 }
2983 } else {
2984 $out = "=$val ";
2985 }
2986 # Default to value if one completion, to question if many
a737e074 2987 $rl_attribs->{completer_terminator_character} = (@out == 1 ? $out : '? ');
08a4aec0 2988 return sort @out;
55497cff 2989 }
a737e074 2990 return $term->filename_list($text); # filenames
55497cff 2991}
2992
43aed9ee 2993sub end_report {
2994 print $OUT "Use `q' to quit or `R' to restart. `h q' for details.\n"
2995}
4639966b 2996
55497cff 2997END {
20928eff 2998 $finished = 1 if $inhibit_exit; # So that some keys may be disabled.
2999 $fall_off_end = 1 unless $inhibit_exit;
36477c24 3000 # Do not stop in at_exit() and destructors on exit:
20928eff 3001 $DB::single = !$fall_off_end && !$runnonstop;
3002 DB::fake::at_exit() unless $fall_off_end or $runnonstop;
55497cff 3003}
3004
3005package DB::fake;
3006
3007sub at_exit {
43aed9ee 3008 "Debugged program terminated. Use `q' to quit or `R' to restart.";
55497cff 3009}
3010
36477c24 3011package DB; # Do not trace this 1; below!
3012
d338d6fe 30131;
Unnamed repository; edit this file to name it for gitweb.