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