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