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