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