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