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