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