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