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