+=head1 NAME
+
+C<perl5db.pl> - the perl debugger
+
+=head1 SYNOPSYS
+
+ perl -d your_Perl_script
+
+=head1 DESCRIPTION
+
+C<perl5db.pl> is the perl debugger. It is loaded automatically by Perl when
+you invoke a script with C<perl -d>. This documentation tries to outline the
+structure and services provided by C<perl5db.pl>, and to describe how you
+can use them.
+
+=head1 GENERAL NOTES
+
+The debugger can look pretty forbidding to many Perl programmers. There are
+a number of reasons for this, many stemming out of the debugger's history.
+
+When the debugger was first written, Perl didn't have a lot of its nicer
+features - no references, no lexical variables, no closures, no object-oriented
+programming. So a lot of the things one would normally have done using such
+features was done using global variables, globs and the C<local()> operator
+in creative ways.
+
+Some of these have survived into the current debugger; a few of the more
+interesting and still-useful idioms are noted in this section, along with notes
+on the comments themselves.
+
+=head2 Why not use more lexicals?
+
+Experienced Perl programmers will note that the debugger code tends to use
+mostly package globals rather than lexically-scoped variables. This is done
+to allow a significant amount of control of the debugger from outside the
+debugger itself.
+
+Unfortunately, though the variables are accessible, they're not well
+documented, so it's generally been a decision that hasn't made a lot of
+difference to most users. Where appropriate, comments have been added to
+make variables more accessible and usable, with the understanding that these
+i<are> debugger internals, and are therefore subject to change. Future
+development should probably attempt to replace the globals with a well-defined
+API, but for now, the variables are what we've got.
+
+=head2 Automated variable stacking via C<local()>
+
+As you may recall from reading L<perlop>, the C<local()> operator makes a
+temporary copy of a variable in the current scope. When the scope ends, the
+old copy is restored. This is often used in the debugger to handle the
+automatic stacking of variables during recursive calls:
+
+ sub foo {
+ local $some_global++;
+
+ # Do some stuff, then ...
+ return;
+ }
+
+What happens is that on entry to the subroutine, C<$some_global> is localized,
+then altered. When the subroutine returns, Perl automatically undoes the
+locaization, restoring the previous value. Voila, automatic stack management.
+
+The debugger uses this trick a I<lot>. Of particular note is C<DB::eval>,
+which lets the debugger get control inside of C<eval>'ed code. The debugger
+localizes a saved copy of C<$@> inside the subroutine, which allows it to
+keep C<$@> safe until it C<DB::eval> returns, at which point the previous
+value of C<$@> is restored. This makes it simple (well, I<simpler>) to keep
+track of C<$@> inside C<eval>s which C<eval> other C<eval's>.
+
+In any case, watch for this pattern. It occurs fairly often.
+
+=head2 The C<^> trick
+
+This is used to cleverly reverse the sense of a logical test depending on
+the value of an auxillary variable. For instance, the debugger's C<S>
+(search for subroutines by pattern) allows you to negate the pattern
+like this:
+
+ # Find all non-'foo' subs:
+ S !/foo/
+
+Boolean algebra states that the truth table for XOR looks like this:
+
+=over 4
+
+=item * 0 ^ 0 = 0
+
+(! not present and no match) --> false, don't print
+
+=item * 0 ^ 1 = 1
+
+(! not present and matches) --> true, print
+
+=item * 1 ^ 0 = 1
+
+(! present and no match) --> true, print
+
+=item * 1 ^ 1 = 0
+
+(! present and matches) --> false, don't print
+
+=back
+
+As you can see, the first pair applies when C<!> isn't supplied, and
+the second pair applies when it isn't. The XOR simply allows us to
+compact a more complicated if-then-elseif-else into a more elegant
+(but perhaps overly clever) single test. After all, it needed this
+explanation...
+
+=head2 FLAGS, FLAGS, FLAGS
+
+There is a certain C programming legacy in the debugger. Some variables,
+such as C<$single>, C<$trace>, and C<$frame>, have "magical" values composed
+of 1, 2, 4, etc. (powers of 2) OR'ed together. This allows several pieces
+of state to be stored independently in a single scalar.
+
+A test like
+
+ if ($scalar & 4) ...
+
+is checking to see if the appropriate bit is on. Since each bit can be
+"addressed" independently in this way, C<$scalar> is acting sort of like
+an array of bits. Obviously, since the contents of C<$scalar> are just a
+bit-pattern, we can save and restore it easily (it will just look like
+a number).
+
+The problem, is of course, that this tends to leave magic numbers scattered
+all over your program whenever a bit is set, cleared, or checked. So why do
+it?
+
+=over 4
+
+
+=item * First, doing an arithmetical or bitwise operation on a scalar is
+just about the fastest thing you can do in Perl: C<use constant> actually
+creates a subroutine call, and array hand hash lookups are much slower. Is
+this over-optimization at the expense of readability? Possibly, but the
+debugger accesses these variables a I<lot>. Any rewrite of the code will
+probably have to benchmark alternate implementations and see which is the
+best balance of readability and speed, and then document how it actually
+works.
+
+=item * Second, it's very easy to serialize a scalar number. This is done in
+the restart code; the debugger state variables are saved in C<%ENV> and then
+restored when the debugger is restarted. Having them be just numbers makes
+this trivial.
+
+=item * Third, some of these variables are being shared with the Perl core
+smack in the middle of the interpreter's execution loop. It's much faster for
+a C program (like the interpreter) to check a bit in a scalar than to access
+several different variables (or a Perl array).
+
+=back
+
+=head2 What are those C<XXX> comments for?
+
+Any comment containing C<XXX> means that the comment is either somewhat
+speculative - it's not exactly clear what a given variable or chunk of
+code is doing, or that it is incomplete - the basics may be clear, but the
+subtleties are not completely documented.
+
+Send in a patch if you can clear up, fill out, or clarify an C<XXX>.
+
+=head1 DATA STRUCTURES MAINTAINED BY CORE
+
+There are a number of special data structures provided to the debugger by
+the Perl interpreter.
+
+The array C<@{$main::{'_<'.$filename}}> (aliased locally to C<@dbline> via glob
+assignment) contains the text from C<$filename>, with each element
+corresponding to a single line of C<$filename>.
+
+The hash C<%{'_<'.$filename}> (aliased locally to C<%dbline> via glob
+assignment) contains breakpoints and actions. The keys are line numbers;
+you can set individual values, but not the whole hash. The Perl interpreter
+uses this hash to determine where breakpoints have been set. Any true value is
+considered to be a breakpoint; C<perl5db.pl> uses "$break_condition\0$action".
+Values are magical in numeric context: 1 if the line is breakable, 0 if not.
+
+The scalar ${'_<'.$filename} contains $filename XXX What?
+
+=head1 DEBUGGER STARTUP
+
+When C<perl5db.pl> starts, it reads an rcfile (C<perl5db.ini> for
+non-interactive sessions, C<.perldb> for interactive ones) that can set a number
+of options. In addition, this file may define a subroutine C<&afterinit>
+that will be executed (in the debugger's context) after the debugger has
+initialized itself.
+
+Next, it checks the C<PERLDB_OPTS> environment variable and treats its
+contents as the argument of a debugger <C<O> command.
+
+=head2 STARTUP-ONLY OPTIONS
+
+The foillowing options can only be specified at startup.
+To set them in your rcfile, add a call to
+C<&parse_options("optionName=new_value")>.
+
+=over 4
+
+=item * TTY
+
+the TTY to use for debugging i/o.
+
+=item * noTTY
+
+if set, goes in NonStop mode. On interrupt, if TTY is not set,
+uses the value of noTTY or "/tmp/perldbtty$$" to find TTY using
+Term::Rendezvous. Current variant is to have the name of TTY in this
+file.
+
+=item * ReadLine
+
+If false, a dummy ReadLine is used, so you can debug
+ReadLine applications.
+
+=item * NonStop
+
+if true, no i/o is performed until interrupt.
+
+=item * LineInfo
+
+file or pipe to print line number info to. If it is a
+pipe, a short "emacs like" message is used.
+
+=item * RemotePort
+
+host:port to connect to on remote host for remote debugging.
+
+=back
+
+=head3 SAMPLE RCFILE
+
+ &parse_options("NonStop=1 LineInfo=db.out");
+ sub afterinit { $trace = 1; }
+
+The script will run without human intervention, putting trace
+information into C<db.out>. (If you interrupt it, you had better
+reset C<LineInfo> to something "interactive"!)
+
+=head1 INTERNALS DESCRIPTION
+
+=head2 DEBUGGER INTERFACE VARIABLES
+
+Perl supplies the values for C<%sub>. It effectively inserts
+a C<&DB'DB();> in front of each place that can have a
+breakpoint. At each subroutine call, it calls C<&DB::sub> with
+C<$DB::sub> set to the called subroutine. It also inserts a C<BEGIN
+{require 'perl5db.pl'}> before the first line.
+
+After each C<require>d file is compiled, but before it is executed, a
+call to C<&DB::postponed($main::{'_<'.$filename})> is done. C<$filename>
+is the expanded name of the C<require>d file (as found via C<%INC>).
+
+=head3 IMPORTANT INTERNAL VARIABLES
+
+=head4 C<$CreateTTY>
+
+Used to control when the debugger will attempt to acquire another TTY to be
+used for input.
+
+=over
+
+=item * 1 - on C<fork()>
+
+=item * 2 - debugger is started inside debugger
+
+=item * 4 - on startup
+
+=back
+
+=head4 C<$doret>
+
+The value -2 indicates that no return value should be printed.
+Any other positive value causes C<DB::sub> to print return values.
+
+=head4 C<$evalarg>
+
+The item to be eval'ed by C<DB::eval>. Used to prevent messing with the current
+contents of C<@_> when C<DB::eval> is called.
+
+=head4 C<$frame>
+
+Determines what messages (if any) will get printed when a subroutine (or eval)
+is entered or exited.
+
+=over 4
+
+=item * 0 - No enter/exit messages
+
+=item * 1 - Print "entering" messages on subroutine entry
+
+=item * 2 - Adds exit messages on subroutine exit. If no other flag is on, acts like 1+2.
+
+=item * 4 - Extended messages: C<in|out> I<context>=I<fully-qualified sub name> from I<file>:I<line>>. If no other flag is on, acts like 1+4.
+
+=item * 8 - Adds parameter information to messages, and overloaded stringify and tied FETCH is enabled on the printed arguments. Ignored if C<4> is not on.
+
+=item * 16 - Adds C<I<context> return from I<subname>: I<value>> messages on subroutine/eval exit. Ignored if C<4> is is not on.
+
+=back
+
+To get everything, use C<$frame=30> (or C<o f-30> as a debugger command).
+The debugger internally juggles the value of C<$frame> during execution to
+protect external modules that the debugger uses from getting traced.
+
+=head4 C<$level>
+
+Tracks current debugger nesting level. Used to figure out how many
+C<E<lt>E<gt>> pairs to surround the line number with when the debugger
+outputs a prompt. Also used to help determine if the program has finished
+during command parsing.
+
+=head4 C<$onetimeDump>
+
+Controls what (if anything) C<DB::eval()> will print after evaluating an
+expression.
+
+=over 4
+
+=item * C<undef> - don't print anything
+
+=item * C<dump> - use C<dumpvar.pl> to display the value returned
+
+=item * C<methods> - print the methods callable on the first item returned
+
+=back
+
+=head4 C<$onetimeDumpDepth>
+
+Controls how far down C<dumpvar.pl> will go before printing '...' while
+dumping a structure. Numeric. If C<undef>, print all levels.
+
+=head4 C<$signal>
+
+Used to track whether or not an C<INT> signal has been detected. C<DB::DB()>,
+which is called before every statement, checks this and puts the user into
+command mode if it finds C<$signal> set to a true value.
+
+=head4 C<$single>
+
+Controls behavior during single-stepping. Stacked in C<@stack> on entry to
+each subroutine; popped again at the end of each subroutine.
+
+=over 4
+
+=item * 0 - run continuously.
+
+=item * 1 - single-step, go into subs. The 's' command.
+
+=item * 2 - single-step, don't go into subs. The 'n' command.
+
+=item * 4 - print current sub depth (turned on to force this when "too much
+recursion" occurs.
+
+=back
+
+=head4 C<$trace>
+
+Controls the output of trace information.
+
+=over 4
+
+=item * 1 - The C<t> command was entered to turn on tracing (every line executed is printed)
+
+=item * 2 - watch expressions are active
+
+=item * 4 - user defined a C<watchfunction()> in C<afterinit()>
+
+=back
+
+=head4 C<$slave_editor>
+
+1 if C<LINEINFO> was directed to a pipe; 0 otherwise.
+
+=head4 C<@cmdfhs>
+
+Stack of filehandles that C<DB::readline()> will read commands from.
+Manipulated by the debugger's C<source> command and C<DB::readline()> itself.
+
+=head4 C<@dbline>
+
+Local alias to the magical line array, C<@{$main::{'_<'.$filename}}> ,
+supplied by the Perl interpreter to the debugger. Contains the source.
+
+=head4 C<@old_watch>
+
+Previous values of watch expressions. First set when the expression is
+entered; reset whenever the watch expression changes.
+
+=head4 C<@saved>
+
+Saves important globals (C<$@>, C<$!>, C<$^E>, C<$,>, C<$/>, C<$\>, C<$^W>)
+so that the debugger can substitute safe values while it's running, and
+restore them when it returns control.
+
+=head4 C<@stack>
+
+Saves the current value of C<$single> on entry to a subroutine.
+Manipulated by the C<c> command to turn off tracing in all subs above the
+current one.
+
+=head4 C<@to_watch>
+
+The 'watch' expressions: to be evaluated before each line is executed.
+
+=head4 C<@typeahead>
+
+The typeahead buffer, used by C<DB::readline>.
+
+=head4 C<%alias>
+
+Command aliases. Stored as character strings to be substituted for a command
+entered.
+
+=head4 C<%break_on_load>
+
+Keys are file names, values are 1 (break when this file is loaded) or undef
+(don't break when it is loaded).
+
+=head4 C<%dbline>
+
+Keys are line numbers, values are "condition\0action". If used in numeric
+context, values are 0 if not breakable, 1 if breakable, no matter what is
+in the actual hash entry.
+
+=head4 C<%had_breakpoints>
+
+Keys are file names; values are bitfields:
+
+=over 4
+
+=item * 1 - file has a breakpoint in it.
+
+=item * 2 - file has an action in it.
+
+=back
+
+A zero or undefined value means this file has neither.
+
+=head4 C<%option>
+
+Stores the debugger options. These are character string values.
+
+=head4 C<%postponed>
+
+Saves breakpoints for code that hasn't been compiled yet.
+Keys are subroutine names, values are:
+
+=over 4
+
+=item * 'compile' - break when this sub is compiled
+
+=item * 'break +0 if <condition>' - break (conditionally) at the start of this routine. The condition will be '1' if no condition was specified.
+
+=back
+
+=head4 C<%postponed_file>
+
+This hash keeps track of breakpoints that need to be set for files that have
+not yet been compiled. Keys are filenames; values are references to hashes.
+Each of these hashes is keyed by line number, and its values are breakpoint
+definitions ("condition\0action").
+
+=head1 DEBUGGER INITIALIZATION
+
+The debugger's initialization actually jumps all over the place inside this
+package. This is because there are several BEGIN blocks (which of course
+execute immediately) spread through the code. Why is that?
+
+The debugger needs to be able to change some things and set some things up
+before the debugger code is compiled; most notably, the C<$deep> variable that
+C<DB::sub> uses to tell when a program has recursed deeply. In addition, the
+debugger has to turn off warnings while the debugger code is compiled, but then
+restore them to their original setting before the program being debugged begins
+executing.
+
+The first C<BEGIN> block simply turns off warnings by saving the current
+setting of C<$^W> and then setting it to zero. The second one initializes
+the debugger variables that are needed before the debugger begins executing.
+The third one puts C<$^X> back to its former value.
+
+We'll detail the second C<BEGIN> block later; just remember that if you need
+to initialize something before the debugger starts really executing, that's
+where it has to go.
+
+=cut
+
package DB;
# Debugger for Perl 5.00x; perl5db.pl patch level:
-$VERSION = 1.20;
+$VERSION = 1.21;
$header = "perl5db.pl version $VERSION";
-# It is crucial that there is no lexicals in scope of `eval ""' down below
+=head1 DEBUGGER ROUTINES
+
+=head2 C<DB::eval()>
+
+This function replaces straight C<eval()> inside the debugger; it simplifies
+the process of evaluating code in the user's context.
+
+The code to be evaluated is passedd via the package global variable
+C<$DB::evalarg>; this is done to avoid fiddling with the contents of C<@_>.
+
+We preserve the current settings of X<C<$trace>>, X<C<$single>>, and X<C<$^D>>;
+add the X<C<$usercontext>> (that's the preserved values of C<$@>, C<$!>,
+C<$^E>, C<$,>, C<$/>, C<$\>, and C<$^W>, grabbed when C<DB::DB> got control,
+and the user's current package) and a add a newline before we do the C<eval()>.
+This causes the proper context to be used when the eval is actually done.
+Afterward, we restore C<$trace>, C<$single>, and C<$^D>.
+
+Next we need to handle C<$@> without getting confused. We save C<$@> in a
+local lexical, localize C<$saved[0]> (which is where C<save()> will put
+C<$@>), and then call C<save()> to capture C<$@>, C<$!>, C<$^E>, C<$,>,
+C<$/>, C<$\>, and C<$^W>) and set C<$,>, C<$/>, C<$\>, and C<$^W> to values
+considered sane by the debugger. If there was an C<eval()> error, we print
+it on the debugger's output. If X<C<$onetimedump>> is defined, we call
+X<C<dumpit>> if it's set to 'dump', or X<C<methods>> if it's set to
+'methods'. Setting it to something else causes the debugger to do the eval
+but not print the result - handy if you want to do something else with it
+(the "watch expressions" code does this to get the value of the watch
+expression but not show it unless it matters).
+
+In any case, we then return the list of output from C<eval> to the caller,
+and unwinding restores the former version of C<$@> in C<@saved> as well
+(the localization of C<$saved[0]> goes away at the end of this scope).
+
+=head3 Parameters and variables influencing execution of DB::eval()
+
+C<DB::eval> isn't parameterized in the standard way; this is to keep the
+debugger's calls to C<DB::eval()> from mucking with C<@_>, among other things.
+The variables listed below influence C<DB::eval()>'s execution directly.
+
+=over 4
+
+=item C<$evalarg> - the thing to actually be eval'ed
+
+=item C<$trace> - Current state of execution tracing (see X<$trace>)
+
+=item C<$single> - Current state of single-stepping (see X<$single>)
+
+=item C<$onetimeDump> - what is to be displayed after the evaluation
+
+=item C<$onetimeDumpDepth> - how deep C<dumpit()> should go when dumping results
+
+=back
+
+The following variables are altered by C<DB::eval()> during its execution. They
+are "stacked" via C<local()>, enabling recursive calls to C<DB::eval()>.
+
+=over 4
+
+=item C<@res> - used to capture output from actual C<eval>.
+
+=item C<$otrace> - saved value of C<$trace>.
+
+=item C<$osingle> - saved value of C<$single>.
+
+=item C<$od> - saved value of C<$^D>.
+
+=item C<$saved[0]> - saved value of C<$@>.
+
+=item $\ - for output of C<$@> if there is an evaluation error.
+
+=back
+
+=head3 The problem of lexicals
+
+The context of C<DB::eval()> presents us with some problems. Obviously,
+we want to be 'sandboxed' away from the debugger's internals when we do
+the eval, but we need some way to control how punctuation variables and
+debugger globals are used.
+
+We can't use local, because the code inside C<DB::eval> can see localized
+variables; and we can't use C<my> either for the same reason. The code
+in this routine compromises and uses C<my>.
+
+After this routine is over, we don't have user code executing in the debugger's
+context, so we can use C<my> freely.
+
+=cut
+
+############################################## Begin lexical danger zone
+
+# 'my' variables used here could leak into (that is, be visible in)
+# the context that the code being evaluated is executing in. This means that
+# the code could modify the debugger's variables.
+#
+# Fiddling with the debugger's context could be Bad. We insulate things as
+# much as we can.
+
sub eval {
+
# 'my' would make it visible from user code
- # but so does local! --tchrist [... into @DB::res, not @res. IZ]
+ # but so does local! --tchrist
+ # Remember: this localizes @DB::res, not @main::res.
local @res;
{
- local $otrace = $trace;
- local $osingle = $single;
- local $od = $^D;
- { ($evalarg) = $evalarg =~ /(.*)/s; }
- @res = eval "$usercontext $evalarg;\n"; # '\n' for nice recursive debug
- $trace = $otrace;
- $single = $osingle;
- $^D = $od;
+ # Try to keep the user code from messing with us. Save these so that
+ # even if the eval'ed code changes them, we can put them back again.
+ # Needed because the user could refer directly to the debugger's
+ # package globals (and any 'my' variables in this containing scope)
+ # inside the eval(), and we want to try to stay safe.
+ local $otrace = $trace;
+ local $osingle = $single;
+ local $od = $^D;
+
+ # Untaint the incoming eval() argument.
+ { ($evalarg) = $evalarg =~ /(.*)/s; }
+
+ # $usercontext built in DB::DB near the comment
+ # "set up the context for DB::eval ..."
+ # Evaluate and save any results.
+ @res =
+ eval "$usercontext $evalarg;\n"; # '\n' for nice recursive debug
+
+ # Restore those old values.
+ $trace = $otrace;
+ $single = $osingle;
+ $^D = $od;
}
+
+ # Save the current value of $@, and preserve it in the debugger's copy
+ # of the saved precious globals.
my $at = $@;
- local $saved[0]; # Preserve the old value of $@
+
+ # Since we're only saving $@, we only have to localize the array element
+ # that it will be stored in.
+ local $saved[0]; # Preserve the old value of $@
eval { &DB::save };
+
+ # Now see whether we need to report an error back to the user.
if ($at) {
- local $\ = '';
- print $OUT $at;
- } elsif ($onetimeDump) {
- if ($onetimeDump eq 'dump') {
- local $option{dumpDepth} = $onetimedumpDepth
- if defined $onetimedumpDepth;
- dumpit($OUT, \@res);
- } elsif ($onetimeDump eq 'methods') {
- methods($res[0]) ;
- }
+ local $\ = '';
+ print $OUT $at;
}
+
+ # Display as required by the caller. $onetimeDump and $onetimedumpDepth
+ # are package globals.
+ elsif ($onetimeDump) {
+ if ($onetimeDump eq 'dump') {
+ local $option{dumpDepth} = $onetimedumpDepth
+ if defined $onetimedumpDepth;
+ dumpit($OUT, \@res);
+ }
+ elsif ($onetimeDump eq 'methods') {
+ methods($res[0]);
+ }
+ } ## end elsif ($onetimeDump)
@res;
-}
+} ## end sub eval
+
+############################################## End lexical danger zone
-# After this point it is safe to introduce lexicals
-# However, one should not overdo it: leave as much control from outside as possible
+# After this point it is safe to introduce lexicals.
+# The code being debugged will be executing in its own context, and
+# can't see the inside of the debugger.
#
+# However, one should not overdo it: leave as much control from outside as
+# possible. If you make something a lexical, it's not going to be addressable
+# from outside the debugger even if you know its name.
+
# This file is automatically included if you do perl -d.
# It's probably not useful to include this yourself.
#
# Before venturing further into these twisty passages, it is
# wise to read the perldebguts man page or risk the ire of dragons.
#
-# Perl supplies the values for %sub. It effectively inserts
-# a &DB::DB(); in front of every place that can have a
-# breakpoint. Instead of a subroutine call it calls &DB::sub with
-# $DB::sub being the called subroutine. It also inserts a BEGIN
-# {require 'perl5db.pl'} before the first line.
-#
-# After each `require'd file is compiled, but before it is executed, a
-# call to DB::postponed($main::{'_<'.$filename}) is emulated. Here the
-# $filename is the expanded name of the `require'd file (as found as
-# value of %INC).
-#
-# Additional services from Perl interpreter:
-#
-# if caller() is called from the package DB, it provides some
-# additional data.
-#
-# The array @{$main::{'_<'.$filename}} (herein called @dbline) is the
-# line-by-line contents of $filename.
-#
-# The hash %{'_<'.$filename} (herein called %dbline) contains
-# breakpoints and action (it is keyed by line number), and individual
-# entries are settable (as opposed to the whole hash). Only true/false
-# is important to the interpreter, though the values used by
-# perl5db.pl have the form "$break_condition\0$action". Values are
-# magical in numeric context.
-#
-# The scalar ${'_<'.$filename} contains $filename.
-#
+# (It should be noted that perldebguts will tell you a lot about
+# the uderlying mechanics of how the debugger interfaces into the
+# Perl interpreter, but not a lot about the debugger itself. The new
+# comments in this code try to address this problem.)
+
# Note that no subroutine call is possible until &DB::sub is defined
# (for subroutines defined outside of the package DB). In fact the same is
# true if $deep is not defined.
#
# $Log: perldb.pl,v $
-#
-# At start reads $rcfile that may set important options. This file
-# may define a subroutine &afterinit that will be executed after the
-# debugger is initialized.
-#
-# After $rcfile is read reads environment variable PERLDB_OPTS and parses
-# it as a rest of `O ...' line in debugger prompt.
-#
-# The options that can be specified only at startup:
-# [To set in $rcfile, call &parse_options("optionName=new_value").]
-#
-# TTY - the TTY to use for debugging i/o.
-#
-# noTTY - if set, goes in NonStop mode. On interrupt if TTY is not set
-# uses the value of noTTY or "/tmp/perldbtty$$" to find TTY using
-# Term::Rendezvous. Current variant is to have the name of TTY in this
-# file.
-#
-# ReadLine - If false, dummy ReadLine is used, so you can debug
-# ReadLine applications.
-#
-# NonStop - if true, no i/o is performed until interrupt.
-#
-# LineInfo - file or pipe to print line number info to. If it is a
-# pipe, a short "emacs like" message is used.
-#
-# RemotePort - host:port to connect to on remote host for remote debugging.
-#
-# Example $rcfile: (delete leading hashes!)
-#
-# &parse_options("NonStop=1 LineInfo=db.out");
-# sub afterinit { $trace = 1; }
-#
-# The script will run without human intervention, putting trace
-# information into db.out. (If you interrupt it, you would better
-# reset LineInfo to something "interactive"!)
-#
-##################################################################
# Enhanced by ilya@math.ohio-state.edu (Ilya Zakharevich)
# Johan Vromans -- upgrade to 4.0 pl 10
# Ilya Zakharevich -- patches after 5.001 (and some before ;-)
-# Changelog:
-
-# A lot of things changed after 0.94. First of all, core now informs
-# debugger about entry into XSUBs, overloaded operators, tied operations,
-# BEGIN and END. Handy with `O f=2'.
-
-# This can make debugger a little bit too verbose, please be patient
-# and report your problems promptly.
-
-# Now the option frame has 3 values: 0,1,2.
-
-# Note that if DESTROY returns a reference to the object (or object),
-# the deletion of data may be postponed until the next function call,
-# due to the need to examine the return value.
-
-# Changes: 0.95: `v' command shows versions.
-# Changes: 0.96: `v' command shows version of readline.
-# primitive completion works (dynamic variables, subs for `b' and `l',
-# options). Can `p %var'
-# Better help (`h <' now works). New commands <<, >>, {, {{.
-# {dump|print}_trace() coded (to be able to do it from <<cmd).
-# `c sub' documented.
-# At last enough magic combined to stop after the end of debuggee.
-# !! should work now (thanks to Emacs bracket matching an extra
-# `]' in a regexp is caught).
-# `L', `D' and `A' span files now (as documented).
-# Breakpoints in `require'd code are possible (used in `R').
-# Some additional words on internal work of debugger.
-# `b load filename' implemented.
-# `b postpone subr' implemented.
-# now only `q' exits debugger (overwritable on $inhibit_exit).
-# When restarting debugger breakpoints/actions persist.
-# Buglet: When restarting debugger only one breakpoint/action per
-# autoloaded function persists.
+# (We have made efforts to clarify the comments in the change log
+# in other places; some of them may seem somewhat obscure as they
+# were originally written, and explaining them away from the code
+# in question seems conterproductive.. -JM)
+
+########################################################################
+# Changes: 0.94
+# + A lot of things changed after 0.94. First of all, core now informs
+# debugger about entry into XSUBs, overloaded operators, tied operations,
+# BEGIN and END. Handy with `O f=2'.
+# + This can make debugger a little bit too verbose, please be patient
+# and report your problems promptly.
+# + Now the option frame has 3 values: 0,1,2. XXX Document!
+# + Note that if DESTROY returns a reference to the object (or object),
+# the deletion of data may be postponed until the next function call,
+# due to the need to examine the return value.
+#
+# Changes: 0.95
+# + `v' command shows versions.
+#
+# Changes: 0.96
+# + `v' command shows version of readline.
+# primitive completion works (dynamic variables, subs for `b' and `l',
+# options). Can `p %var'
+# + Better help (`h <' now works). New commands <<, >>, {, {{.
+# {dump|print}_trace() coded (to be able to do it from <<cmd).
+# + `c sub' documented.
+# + At last enough magic combined to stop after the end of debuggee.
+# + !! should work now (thanks to Emacs bracket matching an extra
+# `]' in a regexp is caught).
+# + `L', `D' and `A' span files now (as documented).
+# + Breakpoints in `require'd code are possible (used in `R').
+# + Some additional words on internal work of debugger.
+# + `b load filename' implemented.
+# + `b postpone subr' implemented.
+# + now only `q' exits debugger (overwritable on $inhibit_exit).
+# + When restarting debugger breakpoints/actions persist.
+# + Buglet: When restarting debugger only one breakpoint/action per
+# autoloaded function persists.
+#
# Changes: 0.97: NonStop will not stop in at_exit().
-# Option AutoTrace implemented.
-# Trace printed differently if frames are printed too.
-# new `inhibitExit' option.
-# printing of a very long statement interruptible.
+# + Option AutoTrace implemented.
+# + Trace printed differently if frames are printed too.
+# + new `inhibitExit' option.
+# + printing of a very long statement interruptible.
# Changes: 0.98: New command `m' for printing possible methods
-# 'l -' is a synonym for `-'.
-# Cosmetic bugs in printing stack trace.
-# `frame' & 8 to print "expanded args" in stack trace.
-# Can list/break in imported subs.
-# new `maxTraceLen' option.
-# frame & 4 and frame & 8 granted.
-# new command `m'
-# nonstoppable lines do not have `:' near the line number.
-# `b compile subname' implemented.
-# Will not use $` any more.
-# `-' behaves sane now.
+# + 'l -' is a synonym for `-'.
+# + Cosmetic bugs in printing stack trace.
+# + `frame' & 8 to print "expanded args" in stack trace.
+# + Can list/break in imported subs.
+# + new `maxTraceLen' option.
+# + frame & 4 and frame & 8 granted.
+# + new command `m'
+# + nonstoppable lines do not have `:' near the line number.
+# + `b compile subname' implemented.
+# + Will not use $` any more.
+# + `-' behaves sane now.
# Changes: 0.99: Completion for `f', `m'.
-# `m' will remove duplicate names instead of duplicate functions.
-# `b load' strips trailing whitespace.
-# completion ignores leading `|'; takes into account current package
-# when completing a subroutine name (same for `l').
+# + `m' will remove duplicate names instead of duplicate functions.
+# + `b load' strips trailing whitespace.
+# completion ignores leading `|'; takes into account current package
+# when completing a subroutine name (same for `l').
# Changes: 1.07: Many fixed by tchrist 13-March-2000
# BUG FIXES:
# + Added bare minimal security checks on perldb rc files, plus
# tabs don't seem to help much here.
#
# Changes: 1.09: May 19, 2001 Ilya Zakharevich <ilya@math.ohio-state.edu>
-# 0) Minor bugs corrected;
-# a) Support for auto-creation of new TTY window on startup, either
-# unconditionally, or if started as a kid of another debugger session;
-# b) New `O'ption CreateTTY
-# I<CreateTTY> bits control attempts to create a new TTY on events:
-# 1: on fork() 2: debugger is started inside debugger
-# 4: on startup
-# c) Code to auto-create a new TTY window on OS/2 (currently one
-# extra window per session - need named pipes to have more...);
-# d) Simplified interface for custom createTTY functions (with a backward
-# compatibility hack); now returns the TTY name to use; return of ''
-# means that the function reset the I/O handles itself;
-# d') Better message on the semantic of custom createTTY function;
-# e) Convert the existing code to create a TTY into a custom createTTY
-# function;
-# f) Consistent support for TTY names of the form "TTYin,TTYout";
-# g) Switch line-tracing output too to the created TTY window;
-# h) make `b fork' DWIM with CORE::GLOBAL::fork;
-# i) High-level debugger API cmd_*():
+# Minor bugs corrected;
+# + Support for auto-creation of new TTY window on startup, either
+# unconditionally, or if started as a kid of another debugger session;
+# + New `O'ption CreateTTY
+# I<CreateTTY> bits control attempts to create a new TTY on events:
+# 1: on fork()
+# 2: debugger is started inside debugger
+# 4: on startup
+# + Code to auto-create a new TTY window on OS/2 (currently one
+# extra window per session - need named pipes to have more...);
+# + Simplified interface for custom createTTY functions (with a backward
+# compatibility hack); now returns the TTY name to use; return of ''
+# means that the function reset the I/O handles itself;
+# + Better message on the semantic of custom createTTY function;
+# + Convert the existing code to create a TTY into a custom createTTY
+# function;
+# + Consistent support for TTY names of the form "TTYin,TTYout";
+# + Switch line-tracing output too to the created TTY window;
+# + make `b fork' DWIM with CORE::GLOBAL::fork;
+# + High-level debugger API cmd_*():
# cmd_b_load($filenamepart) # b load filenamepart
# cmd_b_line($lineno [, $cond]) # b lineno [cond]
# cmd_b_sub($sub [, $cond]) # b sub [cond]
# cmd_d($lineno) # d lineno (B)
# The cmd_*() API returns FALSE on failure; in this case it outputs
# the error message to the debugging output.
-# j) Low-level debugger API
+# + Low-level debugger API
# break_on_load($filename) # b load filename
# @files = report_break_on_load() # List files with load-breakpoints
# breakable_line_in_filename($name, $from [, $to])
# # First breakable line in the
# # range $from .. $to. $to defaults
-# # to $from, and may be less than $to
+# # to $from, and may be less than
+# # $to
# breakable_line($from [, $to]) # Same for the current file
# break_on_filename_line($name, $lineno [, $cond])
-# # Set breakpoint,$cond defaults to 1
+# # Set breakpoint,$cond defaults to
+# # 1
# break_on_filename_line_range($name, $from, $to [, $cond])
# # As above, on the first
# # breakable line in range
# + Added *dbline explainatory comments
# + Mentioning perldebguts man page
# Changes: 1.16: Feb 15, 2002 Mark-Jason Dominus <mjd@plover.com>
-# + $onetimeDump improvements
+# + $onetimeDump improvements
# Changes: 1.17: Feb 20, 2002 Richard Foley <richard.foley@rfi.net>
# Moved some code to cmd_[.]()'s for clarity and ease of handling,
# rationalised the following commands and added cmd_wrapper() to
# behaviours for diehards: 'o CommandSet=pre580' (sigh...)
# a(add), A(del) # action expr (added del by line)
# + b(add), B(del) # break [line] (was b,D)
-# + w(add), W(del) # watch expr (was W,W) added del by expr
+# + w(add), W(del) # watch expr (was W,W)
+# # added del by expr
# + h(summary), h h(long) # help (hh) (was h h,h)
# + m(methods), M(modules) # ... (was m,v)
# + o(option) # lc (was O)
# Changes: 1.20: Feb 17, 2003 Richard Foley <richard.foley@rfi.net>
# + pre'n'post commands no longer trashed with no args
# + watch val joined out of eval()
-#
+# Changes: 1.21: Aug 04, 2002 Joe McMahon (mcmahon@ibiblio.org)
+# + Added comments and reformatted source. No bug fixes/enhancements.
+
####################################################################
-# Needed for the statement after exec():
+=head1 DEBUGGER INITIALIZATION
-BEGIN { $ini_warn = $^W; $^W = 0 } # Switch compilation warnings off until another BEGIN.
+The debugger starts up in phases.
-# test if assertions are supported and actived:
-BEGIN {
- $ini_assertion=
- eval "sub asserting_test : assertion {1}; 1";
- # $ini_assertion = undef => assertions unsupported,
- # " = 1 => assertions suported
- # print "\$ini_assertion=$ini_assertion\n";
-}
+=head2 BASIC SETUP
+
+First, it initializes the environment it wants to run in: turning off
+warnings during its own compilation, defining variables which it will need
+to avoid warnings later, setting itself up to not exit when the program
+terminates, and defaulting to printing return values for the C<r> command.
-local($^W) = 0; # Switch run-time warnings off during init.
-warn ( # Do not ;-)
- $dumpvar::hashDepth,
- $dumpvar::arrayDepth,
- $dumpvar::dumpDBFiles,
- $dumpvar::dumpPackages,
- $dumpvar::quoteHighBit,
- $dumpvar::printUndef,
- $dumpvar::globPrint,
- $dumpvar::usageOnly,
- @ARGS,
- $Carp::CarpLevel,
- $panic,
- $second_time,
- ) if 0;
+=cut
+
+# Needed for the statement after exec():
+#
+# This BEGIN block is simply used to switch off warnings during debugger
+# compiliation. Probably it would be better practice to fix the warnings,
+# but this is how it's done at the moment.
+
+BEGIN {
+ $ini_warn = $^W;
+ $^W = 0;
+} # Switch compilation warnings off until another BEGIN.
+
+local ($^W) = 0; # Switch run-time warnings off during init.
+
+# This would probably be better done with "use vars", but that wasn't around
+# when this code was originally written. (Neither was "use strict".) And on
+# the principle of not fiddling with something that was working, this was
+# left alone.
+warn( # Do not ;-)
+ # These variables control the execution of 'dumpvar.pl'.
+ $dumpvar::hashDepth,
+ $dumpvar::arrayDepth,
+ $dumpvar::dumpDBFiles,
+ $dumpvar::dumpPackages,
+ $dumpvar::quoteHighBit,
+ $dumpvar::printUndef,
+ $dumpvar::globPrint,
+ $dumpvar::usageOnly,
+
+ # used to save @ARGV and extract any debugger-related flags.
+ @ARGS,
+
+ # used to control die() reporting in diesignal()
+ $Carp::CarpLevel,
+
+ # used to prevent multiple entries to diesignal()
+ # (if for instance diesignal() itself dies)
+ $panic,
+
+ # used to prevent the debugger from running nonstop
+ # after a restart
+ $second_time,
+ )
+ if 0;
# Command-line + PERLLIB:
+# Save the contents of @INC before they are modified elsewhere.
@ini_INC = @INC;
+# This was an attempt to clear out the previous values of various
+# trapped errors. Apparently it didn't help. XXX More info needed!
# $prevwarn = $prevdie = $prevbus = $prevsegv = ''; # Does not help?!
-$trace = $signal = $single = 0; # Uninitialized warning suppression
- # (local $^W cannot help - other packages!).
+# We set these variables to safe values. We don't want to blindly turn
+# off warnings, because other packages may still want them.
+$trace = $signal = $single = 0; # Uninitialized warning suppression
+ # (local $^W cannot help - other packages!).
+
+# Default to not exiting when program finishes; print the return
+# value when the 'r' command is used to return from a subroutine.
$inhibit_exit = $option{PrintRet} = 1;
-@options = qw(hashDepth arrayDepth CommandSet dumpDepth
- DumpDBFiles DumpPackages DumpReused
- compactDump veryCompact quote HighBit undefPrint
- globPrint PrintRet UsageOnly frame AutoTrace
- TTY noTTY ReadLine NonStop LineInfo maxTraceLen
- recallCommand ShellBang pager tkRunning ornaments
- signalLevel warnLevel dieLevel inhibit_exit
- ImmediateStop bareStringify CreateTTY
- RemotePort windowSize DollarCaretP OnlyAssertions
- WarnAssertions);
-
-@RememberOnROptions = qw(DollarCaretP OnlyAssertions);
-
-%optionVars = (
- hashDepth => \$dumpvar::hashDepth,
- arrayDepth => \$dumpvar::arrayDepth,
- CommandSet => \$CommandSet,
- DumpDBFiles => \$dumpvar::dumpDBFiles,
- DumpPackages => \$dumpvar::dumpPackages,
- DumpReused => \$dumpvar::dumpReused,
- HighBit => \$dumpvar::quoteHighBit,
- undefPrint => \$dumpvar::printUndef,
- globPrint => \$dumpvar::globPrint,
- UsageOnly => \$dumpvar::usageOnly,
- CreateTTY => \$CreateTTY,
- bareStringify => \$dumpvar::bareStringify,
- frame => \$frame,
- AutoTrace => \$trace,
- inhibit_exit => \$inhibit_exit,
- maxTraceLen => \$maxtrace,
- ImmediateStop => \$ImmediateStop,
- RemotePort => \$remoteport,
- windowSize => \$window,
- WarnAssertions => \$warnassertions,
-);
-
-%optionAction = (
- compactDump => \&dumpvar::compactDump,
- veryCompact => \&dumpvar::veryCompact,
- quote => \&dumpvar::quote,
- TTY => \&TTY,
- noTTY => \&noTTY,
- ReadLine => \&ReadLine,
- NonStop => \&NonStop,
- LineInfo => \&LineInfo,
- recallCommand => \&recallCommand,
- ShellBang => \&shellBang,
- pager => \&pager,
- signalLevel => \&signalLevel,
- warnLevel => \&warnLevel,
- dieLevel => \&dieLevel,
- tkRunning => \&tkRunning,
- ornaments => \&ornaments,
- RemotePort => \&RemotePort,
- DollarCaretP => \&DollarCaretP,
- OnlyAssertions=> \&OnlyAssertions,
- );
+=head1 OPTION PROCESSING
+
+The debugger's options are actually spread out over the debugger itself and
+C<dumpvar.pl>; some of these are variables to be set, while others are
+subs to be called with a value. To try to make this a little easier to
+manage, the debugger uses a few data structures to define what options
+are legal and how they are to be processed.
+
+First, the C<@options> array defines the I<names> of all the options that
+are to be accepted.
+
+=cut
+
+@options = qw(
+ CommandSet
+ hashDepth arrayDepth dumpDepth
+ DumpDBFiles DumpPackages DumpReused
+ compactDump veryCompact quote
+ HighBit undefPrint globPrint
+ PrintRet UsageOnly frame
+ AutoTrace TTY noTTY
+ ReadLine NonStop LineInfo
+ maxTraceLen recallCommand ShellBang
+ pager tkRunning ornaments
+ signalLevel warnLevel dieLevel
+ inhibit_exit ImmediateStop bareStringify
+ CreateTTY RemotePort windowSize
+ );
+
+=pod
+
+Second, C<optionVars> lists the variables that each option uses to save its
+state.
+
+=cut
+
+%optionVars = (
+ hashDepth => \$dumpvar::hashDepth,
+ arrayDepth => \$dumpvar::arrayDepth,
+ CommandSet => \$CommandSet,
+ DumpDBFiles => \$dumpvar::dumpDBFiles,
+ DumpPackages => \$dumpvar::dumpPackages,
+ DumpReused => \$dumpvar::dumpReused,
+ HighBit => \$dumpvar::quoteHighBit,
+ undefPrint => \$dumpvar::printUndef,
+ globPrint => \$dumpvar::globPrint,
+ UsageOnly => \$dumpvar::usageOnly,
+ CreateTTY => \$CreateTTY,
+ bareStringify => \$dumpvar::bareStringify,
+ frame => \$frame,
+ AutoTrace => \$trace,
+ inhibit_exit => \$inhibit_exit,
+ maxTraceLen => \$maxtrace,
+ ImmediateStop => \$ImmediateStop,
+ RemotePort => \$remoteport,
+ windowSize => \$window,
+ );
-%optionRequire = (
- compactDump => 'dumpvar.pl',
- veryCompact => 'dumpvar.pl',
- quote => 'dumpvar.pl',
- );
+=pod
+
+Third, C<%optionAction> defines the subroutine to be called to process each
+option.
+
+=cut
+
+%optionAction = (
+ compactDump => \&dumpvar::compactDump,
+ veryCompact => \&dumpvar::veryCompact,
+ quote => \&dumpvar::quote,
+ TTY => \&TTY,
+ noTTY => \&noTTY,
+ ReadLine => \&ReadLine,
+ NonStop => \&NonStop,
+ LineInfo => \&LineInfo,
+ recallCommand => \&recallCommand,
+ ShellBang => \&shellBang,
+ pager => \&pager,
+ signalLevel => \&signalLevel,
+ warnLevel => \&warnLevel,
+ dieLevel => \&dieLevel,
+ tkRunning => \&tkRunning,
+ ornaments => \&ornaments,
+ RemotePort => \&RemotePort,
+ );
+
+=pod
+
+Last, the C<%optionRequire> notes modules that must be C<require>d if an
+option is used.
+
+=cut
+
+# Note that this list is not complete: several options not listed here
+# actually require that dumpvar.pl be loaded for them to work, but are
+# not in the table. A subsequent patch will correct this problem; for
+# the moment, we're just recommenting, and we are NOT going to change
+# function.
+%optionRequire = (
+ compactDump => 'dumpvar.pl',
+ veryCompact => 'dumpvar.pl',
+ quote => 'dumpvar.pl',
+ );
+
+=pod
+
+There are a number of initialization-related variables which can be set
+by putting code to set them in a BEGIN block in the C<PERL5DB> environment
+variable. These are:
+
+=over 4
+
+=item C<$rl> - readline control XXX needs more explanation
+
+=item C<$warnLevel> - whether or not debugger takes over warning handling
+
+=item C<$dieLevel> - whether or not debugger takes over die handling
+
+=item C<$signalLevel> - whether or not debugger takes over signal handling
+
+=item C<$pre> - preprompt actions (array reference)
+
+=item C<$post> - postprompt actions (array reference)
+
+=item C<$pretype>
+
+=item C<$CreateTTY> - whether or not to create a new TTY for this debugger
+
+=item C<$CommandSet> - which command set to use (defaults to new, documented set)
+
+=cut
# These guys may be defined in $ENV{PERL5DB} :
-$rl = 1 unless defined $rl;
-$warnLevel = 1 unless defined $warnLevel;
-$dieLevel = 1 unless defined $dieLevel;
-$signalLevel = 1 unless defined $signalLevel;
-$pre = [] unless defined $pre;
-$post = [] unless defined $post;
-$pretype = [] unless defined $pretype;
-$CreateTTY = 3 unless defined $CreateTTY;
-$CommandSet = '580' unless defined $CommandSet;
+$rl = 1 unless defined $rl;
+$warnLevel = 1 unless defined $warnLevel;
+$dieLevel = 1 unless defined $dieLevel;
+$signalLevel = 1 unless defined $signalLevel;
+$pre = [] unless defined $pre;
+$post = [] unless defined $post;
+$pretype = [] unless defined $pretype;
+$CreateTTY = 3 unless defined $CreateTTY;
+$CommandSet = '580' unless defined $CommandSet;
+
+=pod
+
+The default C<die>, C<warn>, and C<signal> handlers are set up.
+
+=cut
warnLevel($warnLevel);
dieLevel($dieLevel);
signalLevel($signalLevel);
+=pod
+
+The pager to be used is needed next. We try to get it from the enviroment first.
+if it's not defined there, we try to find it in the Perl C<Config.pm>.
+If it's not there, we default to C<more>. We then call the C<pager()>
+fucntion to save the pager name.
+
+=cut
+
+# This routine makes sure $pager is set up so that '|' can use it.
pager(
- defined $ENV{PAGER} ? $ENV{PAGER} :
- eval { require Config } &&
- defined $Config::Config{pager} ? $Config::Config{pager}
- : 'more'
- ) unless defined $pager;
+ # If PAGER is defined in the environment, use it.
+ defined $ENV{PAGER}
+ ? $ENV{PAGER}
+
+ # If not, see if Config.pm defines it.
+ : eval { require Config } && defined $Config::Config{pager}
+ ? $Config::Config{pager}
+
+ # If not, fall back to 'more'.
+ : 'more'
+ )
+ unless defined $pager;
+
+=pod
+
+We set up the command to be used to access the man pages, the command
+recall character ("!" unless otherwise defined) and the shell escape
+character ("!" unless otherwise defined). Yes, these do conflict, and
+neither works in the debugger at the moment.
+
+=cut
+
setman();
+
+# Set up defaults for command recall and shell escape (note:
+# these currently don't work in linemode debugging).
&recallCommand("!") unless defined $prc;
-&shellBang("!") unless defined $psh;
+&shellBang("!") unless defined $psh;
+
+=pod
+
+We then set up the gigantic string containing the debugger help.
+We also set the limit on the number of arguments we'll display during a
+trace.
+
+=cut
+
sethelp();
+
+# If we didn't get a default for the length of eval/stack trace args,
+# set it here.
$maxtrace = 400 unless defined $maxtrace;
+
+=head2 SETTING UP THE DEBUGGER GREETING
+
+The debugger 'greeting' helps to inform the user how many debuggers are
+running, and whether the current debugger is the primary or a child.
+
+If we are the primary, we just hang onto our pid so we'll have it when
+or if we start a child debugger. If we are a child, we'll set things up
+so we'll have a unique greeting and so the parent will give us our own
+TTY later.
+
+We save the current contents of the C<PERLDB_PIDS> environment variable
+because we mess around with it. We'll also need to hang onto it because
+we'll need it if we restart.
+
+Child debuggers make a label out of the current PID structure recorded in
+PERLDB_PIDS plus the new PID. They also mark themselves as not having a TTY
+yet so the parent will give them one later via C<resetterm()>.
+
+=cut
+
+# Save the current contents of the environment; we're about to
+# much with it. We'll need this if we have to restart.
$ini_pids = $ENV{PERLDB_PIDS};
-if (defined $ENV{PERLDB_PIDS}) {
- $pids = "[$ENV{PERLDB_PIDS}]";
- $ENV{PERLDB_PIDS} .= "->$$";
- $term_pid = -1;
-} else {
- $ENV{PERLDB_PIDS} = "$$";
- $pids = "{pid=$$}";
- $term_pid = $$;
+
+if (defined $ENV{PERLDB_PIDS}) {
+ # We're a child. Make us a label out of the current PID structure
+ # recorded in PERLDB_PIDS plus our (new) PID. Mark us as not having
+ # a term yet so the parent will give us one later via resetterm().
+ $pids = "[$ENV{PERLDB_PIDS}]";
+ $ENV{PERLDB_PIDS} .= "->$$";
+ $term_pid = -1;
+} ## end if (defined $ENV{PERLDB_PIDS...
+else {
+ # We're the parent PID. Initialize PERLDB_PID in case we end up with a
+ # child debugger, and mark us as the parent, so we'll know to set up
+ # more TTY's is we have to.
+ $ENV{PERLDB_PIDS} = "$$";
+ $pids = "{pid=$$}";
+ $term_pid = $$;
}
+
$pidprompt = '';
-*emacs = $slave_editor if $slave_editor; # May be used in afterinit()...
-if (-e "/dev/tty") { # this is the wrong metric!
- $rcfile=".perldb";
-} else {
- $rcfile="perldb.ini";
+# Sets up $emacs as a synonym for $slave_editor.
+*emacs = $slave_editor if $slave_editor; # May be used in afterinit()...
+
+=head2 READING THE RC FILE
+
+The debugger will read a file of initialization options if supplied. If
+running interactively, this is C<.perldb>; if not, it's C<perldb.ini>.
+
+=cut
+
+# As noted, this test really doesn't check accurately that the debugger
+# is running at a terminal or not.
+if (-e "/dev/tty") { # this is the wrong metric!
+ $rcfile = ".perldb";
}
+else {
+ $rcfile = "perldb.ini";
+}
+
+=pod
+
+The debugger does a safety test of the file to be read. It must be owned
+either by the current user or root, and must only be writable by the owner.
+
+=cut
+# This wraps a safety test around "do" to read and evaluate the init file.
+#
# This isn't really safe, because there's a race
# between checking and opening. The solution is to
# open and fstat the handle, but then you have to read and
# eval the contents. But then the silly thing gets
-# your lexical scope, which is unfortunately at best.
-sub safe_do {
+# your lexical scope, which is unfortunate at best.
+sub safe_do {
my $file = shift;
# Just exactly what part of the word "CORE::" don't you understand?
- local $SIG{__WARN__};
- local $SIG{__DIE__};
+ local $SIG{__WARN__};
+ local $SIG{__DIE__};
unless (is_safe_file($file)) {
- CORE::warn <<EO_GRIPE;
+ CORE::warn <<EO_GRIPE;
perldb: Must not source insecure rcfile $file.
You or the superuser must be the owner, and it must not
- be writable by anyone but its owner.
+ be writable by anyone but its owner.
EO_GRIPE
- return;
- }
+ return;
+ } ## end unless (is_safe_file($file...
do $file;
CORE::warn("perldb: couldn't parse $file: $@") if $@;
-}
-
+} ## end sub safe_do
+# This is the safety test itself.
+#
# Verifies that owner is either real user or superuser and that no
# one but owner may write to it. This function is of limited use
# when called on a path instead of upon a handle, because there are
# Assumes that the file's existence is not in doubt.
sub is_safe_file {
my $path = shift;
- stat($path) || return; # mysteriously vaporized
- my($dev,$ino,$mode,$nlink,$uid,$gid) = stat(_);
+ stat($path) || return; # mysteriously vaporized
+ my ($dev, $ino, $mode, $nlink, $uid, $gid) = stat(_);
return 0 if $uid != 0 && $uid != $<;
return 0 if $mode & 022;
return 1;
-}
+} ## end sub is_safe_file
+# If the rcfile (whichever one we decided was the right one to read)
+# exists, we safely do it.
if (-f $rcfile) {
safe_do("./$rcfile");
-}
+}
+# If there isn't one here, try the user's home directory.
elsif (defined $ENV{HOME} && -f "$ENV{HOME}/$rcfile") {
safe_do("$ENV{HOME}/$rcfile");
}
+# Else try the login directory.
elsif (defined $ENV{LOGDIR} && -f "$ENV{LOGDIR}/$rcfile") {
safe_do("$ENV{LOGDIR}/$rcfile");
}
+# If the PERLDB_OPTS variable has options in it, parse those out next.
if (defined $ENV{PERLDB_OPTS}) {
- parse_options($ENV{PERLDB_OPTS});
+ parse_options($ENV{PERLDB_OPTS});
}
-if ( not defined &get_fork_TTY and defined $ENV{TERM} and $ENV{TERM} eq 'xterm'
- and defined $ENV{WINDOWID} and defined $ENV{DISPLAY} ) { # _inside_ XTERM?
- *get_fork_TTY = \&xterm_get_fork_TTY;
-} elsif ($^O eq 'os2') {
- *get_fork_TTY = \&os2_get_fork_TTY;
+=pod
+
+The last thing we do during initialization is determine which subroutine is
+to be used to obtain a new terminal when a new debugger is started. Right now,
+the debugger only handles X Windows and OS/2.
+
+=cut
+
+# Set up the get_fork_TTY subroutine to be aliased to the proper routine.
+# Works if you're running an xterm or xterm-like window, or you're on
+# OS/2. This may need some expansion: for instance, this doesn't handle
+# OS X Terminal windows.
+
+if (not defined &get_fork_TTY # no routine exists,
+ and defined $ENV{TERM} # and we know what kind
+ # of terminal this is,
+ and $ENV{TERM} eq 'xterm' # and it's an xterm,
+ and defined $ENV{WINDOWID} # and we know what
+ # window this is,
+ and defined $ENV{DISPLAY}) # and what display it's
+ # on,
+{
+ *get_fork_TTY = \&xterm_get_fork_TTY; # use the xterm version
+} ## end if (not defined &get_fork_TTY...
+elsif ($^O eq 'os2') { # If this is OS/2,
+ *get_fork_TTY = \&os2_get_fork_TTY; # use the OS/2 version
}
-# Here begin the unreadable code. It needs fixing.
+# "Here begin the unreadable code. It needs fixing."
+
+=head2 RESTART PROCESSING
+
+This section handles the restart command. When the C<R> command is invoked, it
+tries to capture all of the state it can into environment variables, and
+then sets C<PERLDB_RESTART>. When we start executing again, we check to see
+if C<PERLDB_RESTART> is there; if so, we reload all the information that
+the R command stuffed into the environment variables.
+
+ PERLDB_RESTART - flag only, contains no restart data itself.
+ PERLDB_HIST - command history, if it's available
+ PERLDB_ON_LOAD - breakpoints set by the rc file
+ PERLDB_POSTPONE - subs that have been loaded/not executed, and have actions
+ PERLDB_VISITED - files that had breakpoints
+ PERLDB_FILE_... - breakpoints for a file
+ PERLDB_OPT - active options
+ PERLDB_INC - the original @INC
+ PERLDB_PRETYPE - preprompt debugger actions
+ PERLDB_PRE - preprompt Perl code
+ PERLDB_POST - post-prompt Perl code
+ PERLDB_TYPEAHEAD - typeahead captured by readline()
+
+We chug through all these variables and plug the values saved in them
+back into the appropriate spots in the debugger.
+
+=cut
if (exists $ENV{PERLDB_RESTART}) {
- delete $ENV{PERLDB_RESTART};
- # $restart = 1;
- @hist = get_list('PERLDB_HIST');
- %break_on_load = get_list("PERLDB_ON_LOAD");
- %postponed = get_list("PERLDB_POSTPONE");
- my @had_breakpoints= get_list("PERLDB_VISITED");
- for (0 .. $#had_breakpoints) {
- my %pf = get_list("PERLDB_FILE_$_");
- $postponed_file{$had_breakpoints[$_]} = \%pf if %pf;
- }
- my %opt = get_list("PERLDB_OPT");
- my ($opt,$val);
- while (($opt,$val) = each %opt) {
- $val =~ s/[\\\']/\\$1/g;
- parse_options("$opt'$val'");
- }
- @INC = get_list("PERLDB_INC");
- @ini_INC = @INC;
- $pretype = [get_list("PERLDB_PRETYPE")];
- $pre = [get_list("PERLDB_PRE")];
- $post = [get_list("PERLDB_POST")];
- @typeahead = get_list("PERLDB_TYPEAHEAD", @typeahead);
-}
+ # We're restarting, so we don't need the flag that says to restart anymore.
+ delete $ENV{PERLDB_RESTART};
+ # $restart = 1;
+ @hist = get_list('PERLDB_HIST');
+ %break_on_load = get_list("PERLDB_ON_LOAD");
+ %postponed = get_list("PERLDB_POSTPONE");
+
+ # restore breakpoints/actions
+ my @had_breakpoints = get_list("PERLDB_VISITED");
+ for (0 .. $#had_breakpoints) {
+ my %pf = get_list("PERLDB_FILE_$_");
+ $postponed_file{ $had_breakpoints[$_] } = \%pf if %pf;
+ }
+
+ # restore options
+ my %opt = get_list("PERLDB_OPT");
+ my ($opt, $val);
+ while (($opt, $val) = each %opt) {
+ $val =~ s/[\\\']/\\$1/g;
+ parse_options("$opt'$val'");
+ }
+
+ # restore original @INC
+ @INC = get_list("PERLDB_INC");
+ @ini_INC = @INC;
+
+ # return pre/postprompt actions and typeahead buffer
+ $pretype = [get_list("PERLDB_PRETYPE")];
+ $pre = [get_list("PERLDB_PRE")];
+ $post = [get_list("PERLDB_POST")];
+ @typeahead = get_list("PERLDB_TYPEAHEAD", @typeahead);
+} ## end if (exists $ENV{PERLDB_RESTART...
+
+=head2 SETTING UP THE TERMINAL
+
+Now, we'll decide how the debugger is going to interact with the user.
+If there's no TTY, we set the debugger to run non-stop; there's not going
+to be anyone there to enter commands.
+
+=cut
if ($notty) {
- $runnonstop = 1;
-} else {
- # Is Perl being run from a slave editor or graphical debugger?
- $slave_editor = ((defined $main::ARGV[0]) and ($main::ARGV[0] eq '-emacs'));
- $rl = 0, shift(@main::ARGV) if $slave_editor;
-
- #require Term::ReadLine;
-
- if ($^O eq 'cygwin') {
- # /dev/tty is binary. use stdin for textmode
- undef $console;
- } elsif (-e "/dev/tty") {
- $console = "/dev/tty";
- } elsif ($^O eq 'dos' or -e "con" or $^O eq 'MSWin32') {
- $console = "con";
- } elsif ($^O eq 'MacOS') {
- if ($MacPerl::Version !~ /MPW/) {
- $console = "Dev:Console:Perl Debug"; # Separate window for application
- } else {
- $console = "Dev:Console";
- }
- } else {
- $console = "sys\$command";
- }
-
- if (($^O eq 'MSWin32') and ($slave_editor or defined $ENV{EMACS})) {
- $console = undef;
- }
-
- if ($^O eq 'NetWare') {
- $console = undef;
- }
-
- # Around a bug:
- if (defined $ENV{OS2_SHELL} and ($slave_editor or $ENV{WINDOWID})) { # In OS/2
- $console = undef;
- }
-
- if ($^O eq 'epoc') {
- $console = undef;
- }
-
- $console = $tty if defined $tty;
-
- if (defined $remoteport) {
- require IO::Socket;
- $OUT = new IO::Socket::INET( Timeout => '10',
- PeerAddr => $remoteport,
- Proto => 'tcp',
- );
- if (!$OUT) { die "Unable to connect to remote host: $remoteport\n"; }
- $IN = $OUT;
- } else {
- create_IN_OUT(4) if $CreateTTY & 4;
- if ($console) {
- my ($i, $o) = split /,/, $console;
- $o = $i unless defined $o;
- open(IN,"+<$i") || open(IN,"<$i") || open(IN,"<&STDIN");
- open(OUT,"+>$o") || open(OUT,">$o") || open(OUT,">&STDERR")
- || open(OUT,">&STDOUT"); # so we don't dongle stdout
- } elsif (not defined $console) {
- open(IN,"<&STDIN");
- open(OUT,">&STDERR") || open(OUT,">&STDOUT"); # so we don't dongle stdout
- $console = 'STDIN/OUT';
- }
- # so open("|more") can read from STDOUT and so we don't dingle stdin
- $IN = \*IN, $OUT = \*OUT if $console or not defined $console;
- }
- my $previous = select($OUT);
- $| = 1; # for DB::OUT
- select($previous);
-
- $LINEINFO = $OUT unless defined $LINEINFO;
- $lineinfo = $console unless defined $lineinfo;
-
- $header =~ s/.Header: ([^,]+),v(\s+\S+\s+\S+).*$/$1$2/;
- unless ($runnonstop) {
- local $\ = '';
- local $, = '';
- if ($term_pid eq '-1') {
- print $OUT "\nDaughter DB session started...\n";
- } else {
- print $OUT "\nLoading DB routines from $header\n";
- print $OUT ("Editor support ",
- $slave_editor ? "enabled" : "available",
- ".\n");
- print $OUT "\nEnter h or `h h' for help, or `$doccmd perldebug' for more help.\n\n";
- }
- }
+ $runnonstop = 1;
}
+=pod
+
+If there is a TTY, we have to determine who it belongs to before we can
+proceed. If this is a slave editor or graphical debugger (denoted by
+the first command-line switch being '-emacs'), we shift this off and
+set C<$rl> to 0 (XXX ostensibly to do straight reads).
+
+=cut
+
+else {
+ # Is Perl being run from a slave editor or graphical debugger?
+ # If so, don't use readline, and set $slave_editor = 1.
+ $slave_editor =
+ ((defined $main::ARGV[0]) and ($main::ARGV[0] eq '-emacs'));
+ $rl = 0, shift (@main::ARGV) if $slave_editor;
+ #require Term::ReadLine;
+
+=pod
+
+We then determine what the console should be on various systems:
+
+=over 4
+
+=item * Cygwin - We use C<stdin> instead of a separate device.
+
+=cut
+
+
+ if ($^O eq 'cygwin') {
+ # /dev/tty is binary. use stdin for textmode
+ undef $console;
+ }
+
+=item * Unix - use C</dev/tty>.
+
+=cut
+
+ elsif (-e "/dev/tty") {
+ $console = "/dev/tty";
+ }
+
+=item * Windows or MSDOS - use C<con>.
+
+=cut
+
+ elsif ($^O eq 'dos' or -e "con" or $^O eq 'MSWin32') {
+ $console = "con";
+ }
+
+=item * MacOS - use C<Dev:Console:Perl Debug> if this is the MPW version; C<Dev:
+Console> if not. (Note that Mac OS X returns 'darwin', not 'MacOS'. Also note that the debugger doesn't do anything special for 'darwin'. Maybe it should.)
+
+=cut
+
+ elsif ($^O eq 'MacOS') {
+ if ($MacPerl::Version !~ /MPW/) {
+ $console =
+ "Dev:Console:Perl Debug"; # Separate window for application
+ }
+ else {
+ $console = "Dev:Console";
+ }
+ } ## end elsif ($^O eq 'MacOS')
+
+=item * VMS - use C<sys$command>.
+
+=cut
+
+ else {
+ # everything else is ...
+ $console = "sys\$command";
+ }
+
+=pod
+
+=back
+
+Several other systems don't use a specific console. We C<undef $console>
+for those (Windows using a slave editor/graphical debugger, NetWare, OS/2
+with a slave editor, Epoc).
+
+=cut
+
+ if (($^O eq 'MSWin32') and ($slave_editor or defined $ENV{EMACS})) {
+ # /dev/tty is binary. use stdin for textmode
+ $console = undef;
+ }
+
+ if ($^O eq 'NetWare') {
+ # /dev/tty is binary. use stdin for textmode
+ $console = undef;
+ }
+
+ # In OS/2, we need to use STDIN to get textmode too, even though
+ # it pretty much looks like Unix otherwise.
+ if (defined $ENV{OS2_SHELL} and ($slave_editor or $ENV{WINDOWID}))
+ { # In OS/2
+ $console = undef;
+ }
+ # EPOC also falls into the 'got to use STDIN' camp.
+ if ($^O eq 'epoc') {
+ $console = undef;
+ }
+
+=pod
+
+If there is a TTY hanging around from a parent, we use that as the console.
+
+=cut
+
+ $console = $tty if defined $tty;
+
+=head2 SOCKET HANDLING
+
+The debugger is capable of opening a socket and carrying out a debugging
+session over the socket.
+
+If C<RemotePort> was defined in the options, the debugger assumes that it
+should try to start a debugging session on that port. It builds the socket
+and then tries to connect the input and output filehandles to it.
+
+=cut
+
+ # Handle socket stuff.
+ if (defined $remoteport) {
+ # If RemotePort was defined in the options, connect input and output
+ # to the socket.
+ require IO::Socket;
+ $OUT = new IO::Socket::INET(
+ Timeout => '10',
+ PeerAddr => $remoteport,
+ Proto => 'tcp',
+ );
+ if (!$OUT) { die "Unable to connect to remote host: $remoteport\n"; }
+ $IN = $OUT;
+ } ## end if (defined $remoteport)
+
+=pod
+
+If no C<RemotePort> was defined, and we want to create a TTY on startup,
+this is probably a situation where multiple debuggers are running (for example,
+a backticked command that starts up another debugger). We create a new IN and
+OUT filehandle, and do the necessary mojo to create a new TTY if we know how
+and if we can.
+
+=cut
+
+ # Non-socket.
+ else {
+ # Two debuggers running (probably a system or a backtick that invokes
+ # the debugger itself under the running one). create a new IN and OUT
+ # filehandle, and do the necessary mojo to create a new tty if we
+ # know how, and we can.
+ create_IN_OUT(4) if $CreateTTY & 4;
+ if ($console) {
+ # If we have a console, check to see if there are separate ins and
+ # outs to open. (They are assumed identiical if not.)
+ my ($i, $o) = split /,/, $console;
+ $o = $i unless defined $o;
+
+ # read/write on in, or just read, or read on STDIN.
+ open(IN, "+<$i") ||
+ open(IN, "<$i") ||
+ open(IN, "<&STDIN");
+
+ # read/write/create/clobber out, or write/create/clobber out,
+ # or merge with STDERR, or merge with STDOUT.
+ open(OUT, "+>$o") ||
+ open(OUT, ">$o") ||
+ open(OUT, ">&STDERR") ||
+ open(OUT, ">&STDOUT"); # so we don't dongle stdout
+
+ } ## end if ($console)
+ elsif (not defined $console) {
+ # No console. Open STDIN.
+ open(IN, "<&STDIN");
+
+ # merge with STDERR, or with STDOUT.
+ open(OUT, ">&STDERR") ||
+ open(OUT, ">&STDOUT"); # so we don't dongle stdout
+
+ $console = 'STDIN/OUT';
+ } ## end elsif (not defined $console)
+
+ # Keep copies of the filehandles so that when the pager runs, it
+ # can close standard input without clobbering ours.
+ $IN = \*IN, $OUT = \*OUT if $console or not defined $console;
+ } ## end elsif (from if(defined $remoteport))
+
+ # Unbuffer DB::OUT. We need to see responses right away.
+ my $previous = select($OUT);
+ $| = 1; # for DB::OUT
+ select($previous);
+
+ # Line info goes to debugger output unless pointed elsewhere.
+ # Pointing elsewhere makes it possible for slave editors to
+ # keep track of file and position. We have both a filehandle
+ # and a I/O description to keep track of.
+ $LINEINFO = $OUT unless defined $LINEINFO;
+ $lineinfo = $console unless defined $lineinfo;
+
+=pod
+
+To finish initialization, we show the debugger greeting,
+and then call the C<afterinit()> subroutine if there is one.
+
+=cut
+
+ # Show the debugger greeting.
+ $header =~ s/.Header: ([^,]+),v(\s+\S+\s+\S+).*$/$1$2/;
+ unless ($runnonstop) {
+ local $\ = '';
+ local $, = '';
+ if ($term_pid eq '-1') {
+ print $OUT "\nDaughter DB session started...\n";
+ }
+ else {
+ print $OUT "\nLoading DB routines from $header\n";
+ print $OUT (
+ "Editor support ",
+ $slave_editor ? "enabled" : "available", ".\n"
+ );
+ print $OUT
+"\nEnter h or `h h' for help, or `$doccmd perldebug' for more help.\n\n";
+ } ## end else [ if ($term_pid eq '-1')
+ } ## end unless ($runnonstop)
+} ## end else [ if ($notty)
+
+# XXX This looks like a bug to me.
+# Why copy to @ARGS and then futz with @args?
@ARGS = @ARGV;
for (@args) {
+ # Make sure backslashes before single quotes are stripped out, and
+ # keep args unless they are numeric (XXX why?)
s/\'/\\\'/g;
s/(.*)/'$1'/ unless /^-?[\d.]+$/;
}
-if (defined &afterinit) { # May be defined in $rcfile
- &afterinit();
+# If there was an afterinit() sub defined, call it. It will get
+# executed in our scope, so it can fiddle with debugger globals.
+if (defined &afterinit) { # May be defined in $rcfile
+ &afterinit();
}
-
+# Inform us about "Stack dump during die enabled ..." in dieLevel().
$I_m_init = 1;
############################################################ Subroutines
+=head1 SUBROUTINES
+
+=head2 DB
+
+This gigantic subroutine is the heart of the debugger. Called before every
+statement, its job is to determine if a breakpoint has been reached, and
+stop if so; read commands from the user, parse them, and execute
+them, and hen send execution off to the next statement.
+
+Note that the order in which the commands are processed is very important;
+some commands earlier in the loop will actually alter the C<$cmd> variable
+to create other commands to be executed later. This is all highly "optimized"
+but can be confusing. Check the comments for each C<$cmd ... && do {}> to
+see what's happening in any given command.
+
+=cut
+
sub DB {
+
+ # Check for whether we should be running continuously or not.
# _After_ the perl program is compiled, $single is set to 1:
if ($single and not $second_time++) {
- if ($runnonstop) { # Disable until signal
- for ($i=0; $i <= $stack_depth; ) {
- $stack[$i++] &= ~1;
- }
- $single = 0;
- # return; # Would not print trace!
- } elsif ($ImmediateStop) {
- $ImmediateStop = 0;
- $signal = 1;
- }
- }
- $runnonstop = 0 if $single or $signal; # Disable it if interactive.
+ # Options say run non-stop. Run until we get an interrupt.
+ if ($runnonstop) { # Disable until signal
+ # If there's any call stack in place, turn off single
+ # stepping into subs throughout the stack.
+ for ($i = 0 ; $i <= $stack_depth ;) {
+ $stack[$i++] &= ~1;
+ }
+ # And we are now no longer in single-step mode.
+ $single = 0;
+
+ # If we simply returned at this point, we wouldn't get
+ # the trace info. Fall on through.
+ # return;
+ } ## end if ($runnonstop)
+
+ elsif ($ImmediateStop) {
+ # We are supposed to stop here; XXX probably a break.
+ $ImmediateStop = 0; # We've processed it; turn it off
+ $signal = 1; # Simulate an interrupt to force
+ # us into the command loop
+ }
+ } ## end if ($single and not $second_time...
+
+ # If we're in single-step mode, or an interrupt (real or fake)
+ # has occurred, turn off non-stop mode.
+ $runnonstop = 0 if $single or $signal;
+
+ # Preserve current values of $@, $!, $^E, $,, $/, $\, $^W.
+ # The code being debugged may have altered them.
&save;
- local($package, $filename, $line) = caller;
+
+ # Since DB::DB gets called after every line, we can use caller() to
+ # figure out where we last were executing. Sneaky, eh? This works because
+ # caller is returning all the extra information when called from the
+ # debugger.
+ local ($package, $filename, $line) = caller;
local $filename_ini = $filename;
- local $usercontext = '($@, $!, $^E, $,, $/, $\, $^W) = @saved;' .
- "package $package;"; # this won't let them modify, alas
- local(*dbline) = $main::{'_<' . $filename};
+
+ # set up the context for DB::eval, so it can properly execute
+ # code on behalf of the user. We add the package in so that the
+ # code is eval'ed in the proper package (not in the debugger!).
+ local $usercontext =
+ '($@, $!, $^E, $,, $/, $\, $^W) = @saved;' .
+ "package $package;";
+
+ # Create an alias to the active file magical array to simplify
+ # the code here.
+ local (*dbline) = $main::{ '_<' . $filename };
# we need to check for pseudofiles on Mac OS (these are files
# not attached to a filename, but instead stored in Dev:Pseudo)
if ($^O eq 'MacOS' && $#dbline < 0) {
- $filename_ini = $filename = 'Dev:Pseudo';
- *dbline = $main::{'_<' . $filename};
+ $filename_ini = $filename = 'Dev:Pseudo';
+ *dbline = $main::{ '_<' . $filename };
}
+ # Last line in the program.
local $max = $#dbline;
- if ($dbline{$line} && (($stop,$action) = split(/\0/,$dbline{$line}))) {
- if ($stop eq '1') {
- $signal |= 1;
- } elsif ($stop) {
- $evalarg = "\$DB::signal |= 1 if do {$stop}"; &eval;
- $dbline{$line} =~ s/;9($|\0)/$1/;
- }
- }
+
+ # if we have something here, see if we should break.
+ if ($dbline{$line} && (($stop, $action) = split (/\0/, $dbline{$line}))) {
+ # Stop if the stop criterion says to just stop.
+ if ($stop eq '1') {
+ $signal |= 1;
+ }
+ # It's a conditional stop; eval it in the user's context and
+ # see if we should stop. If so, remove the one-time sigil.
+ elsif ($stop) {
+ $evalarg = "\$DB::signal |= 1 if do {$stop}";
+ &eval;
+ $dbline{$line} =~ s/;9($|\0)/$1/;
+ }
+ } ## end if ($dbline{$line} && ...
+
+ # Preserve the current stop-or-not, and see if any of the W
+ # (watch expressions) has changed.
my $was_signal = $signal;
+
+ # If we have any watch expressions ...
if ($trace & 2) {
- for (my $n = 0; $n <= $#to_watch; $n++) {
- $evalarg = $to_watch[$n];
- local $onetimeDump; # Do not output results
- my ($val) = join("', '", &eval); # Fix context (&eval is doing array)? - rjsf
- $val = ( (defined $val) ? "'$val'" : 'undef' );
- if ($val ne $old_watch[$n]) {
- $signal = 1;
- print $OUT <<EOP;
+ for (my $n = 0 ; $n <= $#to_watch ; $n++) {
+ $evalarg = $to_watch[$n];
+ local $onetimeDump; # Tell DB::eval() to not output results
+
+ # Fix context DB::eval() wants to return an array, but
+ # we need a scalar here.
+ my ($val) =
+ join ( "', '", &eval );
+ $val = ((defined $val) ? "'$val'" : 'undef');
+
+ # Did it change?
+ if ($val ne $old_watch[$n]) {
+ # Yep! Show the difference, and fake an interrupt.
+ $signal = 1;
+ print $OUT <<EOP;
Watchpoint $n:\t$to_watch[$n] changed:
old value:\t$old_watch[$n]
new value:\t$val
EOP
- $old_watch[$n] = $val;
- }
- }
- }
- if ($trace & 4) { # User-installed watch
- return if watchfunction($package, $filename, $line)
- and not $single and not $was_signal and not ($trace & ~4);
- }
+ $old_watch[$n] = $val;
+ } ## end if ($val ne $old_watch...
+ } ## end for (my $n = 0 ; $n <= ...
+ } ## end if ($trace & 2)
+
+=head2 C<watchfunction()>
+
+C<watchfunction()> is a function that can be defined by the user; it is a
+function which will be run on each entry to C<DB::DB>; it gets the
+current package, filename, and line as its parameters.
+
+The watchfunction can do anything it likes; it is executing in the
+debugger's context, so it has access to all of the debugger's internal
+data structures and functions.
+
+C<watchfunction()> can control the debugger's actions. Any of the following
+will cause the debugger to return control to the user's program after
+C<watchfunction()> executes:
+
+=over 4
+
+=item * Returning a false value from the C<watchfunction()> itself.
+
+=item * Altering C<$single> to a false value.
+
+=item * Altering C<$signal> to a false value.
+
+=item * Turning off the '4' bit in C<$trace> (this also disables the
+check for C<watchfunction()>. This can be done with
+
+ $trace &= ~4;
+
+=back
+
+=cut
+
+ # If there's a user-defined DB::watchfunction, call it with the
+ # current package, filename, and line. The function executes in
+ # the DB:: package.
+ if ($trace & 4) { # User-installed watch
+ return
+ if watchfunction($package, $filename, $line)
+ and not $single
+ and not $was_signal
+ and not($trace & ~4);
+ } ## end if ($trace & 4)
+
+
+ # Pick up any alteration to $signal in the watchfunction, and
+ # turn off the signal now.
$was_signal = $signal;
- $signal = 0;
+ $signal = 0;
+
+=head2 GETTING READY TO EXECUTE COMMANDS
+
+The debugger decides to take control if single-step mode is on, the
+C<t> command was entered, or the user generated a signal. If the program
+has fallen off the end, we set things up so that entering further commands
+won't cause trouble, and we say that the program is over.
+
+=cut
+
+ # Check to see if we should grab control ($single true,
+ # trace set appropriately, or we got a signal).
if ($single || ($trace & 1) || $was_signal) {
- if ($slave_editor) {
- $position = "\032\032$filename:$line:0\n";
- print_lineinfo($position);
- } elsif ($package eq 'DB::fake') {
- $term || &setterm;
- print_help(<<EOP);
+ # Yes, grab control.
+ if ($slave_editor) {
+ # Tell the editor to update its position.
+ $position = "\032\032$filename:$line:0\n";
+ print_lineinfo($position);
+ }
+
+=pod
+
+Special check: if we're in package C<DB::fake>, we've gone through the
+C<END> block at least once. We set up everything so that we can continue
+to enter commands and have a valid context to be in.
+
+=cut
+
+ elsif ($package eq 'DB::fake') {
+ # Fallen off the end already.
+ $term || &setterm;
+ print_help(<<EOP);
Debugged program terminated. Use B<q> to quit or B<R> to restart,
use B<O> I<inhibit_exit> to avoid stopping after program termination,
B<h q>, B<h R> or B<h O> to get additional info.
EOP
- $package = 'main';
- $usercontext = '($@, $!, $^E, $,, $/, $\, $^W) = @saved;' .
- "package $package;"; # this won't let them modify, alas
- } else {
- $sub =~ s/\'/::/;
- $prefix = $sub =~ /::/ ? "" : "${'package'}::";
- $prefix .= "$sub($filename:";
- $after = ($dbline[$line] =~ /\n$/ ? '' : "\n");
- if (length($prefix) > 30) {
- $position = "$prefix$line):\n$line:\t$dbline[$line]$after";
- $prefix = "";
- $infix = ":\t";
- } else {
- $infix = "):\t";
- $position = "$prefix$line$infix$dbline[$line]$after";
- }
- if ($frame) {
- print_lineinfo(' ' x $stack_depth, "$line:\t$dbline[$line]$after");
- } else {
- print_lineinfo($position);
- }
- for ($i = $line + 1; $i <= $max && $dbline[$i] == 0; ++$i) { #{ vi
- last if $dbline[$i] =~ /^\s*[\;\}\#\n]/;
- last if $signal;
- $after = ($dbline[$i] =~ /\n$/ ? '' : "\n");
- $incr_pos = "$prefix$i$infix$dbline[$i]$after";
- $position .= $incr_pos;
- if ($frame) {
- print_lineinfo(' ' x $stack_depth, "$i:\t$dbline[$i]$after");
- } else {
- print_lineinfo($incr_pos);
- }
- }
- }
- }
+
+ # Set the DB::eval context appropriately.
+ $package = 'main';
+ $usercontext =
+ '($@, $!, $^E, $,, $/, $\, $^W) = @saved;' .
+ "package $package;"; # this won't let them modify, alas
+ } ## end elsif ($package eq 'DB::fake')
+
+=pod
+
+If the program hasn't finished executing, we scan forward to the
+next executable line, print that out, build the prompt from the file and line
+number information, and print that.
+
+=cut
+
+ else {
+ # Still somewhere in the midst of execution. Set up the
+ # debugger prompt.
+ $sub =~ s/\'/::/; # Swap Perl 4 package separators (') to
+ # Perl 5 ones (sorry, we don't print Klingon
+ #module names)
+
+ $prefix = $sub =~ /::/ ? "" : "${'package'}::";
+ $prefix .= "$sub($filename:";
+ $after = ($dbline[$line] =~ /\n$/ ? '' : "\n");
+
+ # Break up the prompt if it's really long.
+ if (length($prefix) > 30) {
+ $position = "$prefix$line):\n$line:\t$dbline[$line]$after";
+ $prefix = "";
+ $infix = ":\t";
+ }
+ else {
+ $infix = "):\t";
+ $position = "$prefix$line$infix$dbline[$line]$after";
+ }
+
+ # Print current line info, indenting if necessary.
+ if ($frame) {
+ print_lineinfo(' ' x $stack_depth,
+ "$line:\t$dbline[$line]$after");
+ }
+ else {
+ print_lineinfo($position);
+ }
+
+ # Scan forward, stopping at either the end or the next
+ # unbreakable line.
+ for ($i = $line + 1 ; $i <= $max && $dbline[$i] == 0 ; ++$i)
+ { #{ vi
+
+ # Drop out on null statements, block closers, and comments.
+ last if $dbline[$i] =~ /^\s*[\;\}\#\n]/;
+
+ # Drop out if the user interrupted us.
+ last if $signal;
+
+ # Append a newline if the line doesn't have one. Can happen
+ # in eval'ed text, for instance.
+ $after = ($dbline[$i] =~ /\n$/ ? '' : "\n");
+
+ # Next executable line.
+ $incr_pos = "$prefix$i$infix$dbline[$i]$after";
+ $position .= $incr_pos;
+ if ($frame) {
+ # Print it indented if tracing is on.
+ print_lineinfo(' ' x $stack_depth,
+ "$i:\t$dbline[$i]$after");
+ }
+ else {
+ print_lineinfo($incr_pos);
+ }
+ } ## end for ($i = $line + 1 ; $i...
+ } ## end else [ if ($slave_editor)
+ } ## end if ($single || ($trace...
+
+=pod
+
+If there's an action to be executed for the line we stopped at, execute it.
+If there are any preprompt actions, execute those as well.
+
+=cut
+
+ # If there's an action, do it now.
$evalarg = $action, &eval if $action;
+
+ # Are we nested another level (e.g., did we evaluate a function
+ # that had a breakpoint in it at the debugger prompt)?
if ($single || $was_signal) {
- local $level = $level + 1;
- foreach $evalarg (@$pre) {
- &eval;
- }
- print $OUT $stack_depth . " levels deep in subroutine calls!\n"
- if $single & 4;
- $start = $line;
- $incr = -1; # for backward motion.
- @typeahead = (@$pretype, @typeahead);
- CMD:
- while (($term || &setterm),
- ($term_pid == $$ or resetterm(1)),
- defined ($cmd=&readline("$pidprompt DB" . ('<' x $level) .
- ($#hist+1) . ('>' x $level) . " ")))
- {
- $single = 0;
- $signal = 0;
- $cmd =~ s/\\$/\n/ && do {
- $cmd .= &readline(" cont: ");
- redo CMD;
- };
- $cmd =~ /^$/ && ($cmd = $laststep);
- push(@hist,$cmd) if length($cmd) > 1;
- PIPE: {
- $cmd =~ s/^\s+//s; # trim annoying leading whitespace
- $cmd =~ s/\s+$//s; # trim annoying trailing whitespace
- ($i) = split(/\s+/,$cmd);
- if ($alias{$i}) {
- # squelch the sigmangler
- local $SIG{__DIE__};
- local $SIG{__WARN__};
- eval "\$cmd =~ $alias{$i}";
- if ($@) {
- local $\ = '';
- print $OUT "Couldn't evaluate `$i' alias: $@";
- next CMD;
- }
- }
- $cmd =~ /^q$/ && do {
- $fall_off_end = 1;
- clean_ENV();
- exit $?;
- };
- $cmd =~ /^t$/ && do {
- $trace ^= 1;
- local $\ = '';
- print $OUT "Trace = " .
- (($trace & 1) ? "on" : "off" ) . "\n";
- next CMD; };
- $cmd =~ /^S(\s+(!)?(.+))?$/ && do {
- $Srev = defined $2; $Spatt = $3; $Snocheck = ! defined $1;
- local $\ = '';
- local $, = '';
- foreach $subname (sort(keys %sub)) {
- if ($Snocheck or $Srev^($subname =~ /$Spatt/)) {
- print $OUT $subname,"\n";
- }
- }
- next CMD; };
- $cmd =~ s/^X\b/V $package/;
- $cmd =~ /^V$/ && do {
- $cmd = "V $package"; };
- $cmd =~ /^V\b\s*(\S+)\s*(.*)/ && do {
- local ($savout) = select($OUT);
- $packname = $1;
- @vars = split(' ',$2);
- do 'dumpvar.pl' unless defined &main::dumpvar;
- if (defined &main::dumpvar) {
- local $frame = 0;
- local $doret = -2;
- # must detect sigpipe failures
- eval { &main::dumpvar($packname,
- defined $option{dumpDepth}
- ? $option{dumpDepth} : -1,
- @vars) };
- if ($@) {
- die unless $@ =~ /dumpvar print failed/;
- }
- } else {
- print $OUT "dumpvar.pl not available.\n";
- }
- select ($savout);
- next CMD; };
- $cmd =~ s/^x\b/ / && do { # So that will be evaled
- $onetimeDump = 'dump';
- # handle special "x 3 blah" syntax
- if ($cmd =~ s/^\s*(\d+)(?=\s)/ /) {
- $onetimedumpDepth = $1;
- }
- };
- $cmd =~ s/^m\s+([\w:]+)\s*$/ / && do {
- methods($1); next CMD};
- $cmd =~ s/^m\b/ / && do { # So this will be evaled
- $onetimeDump = 'methods'; };
- $cmd =~ /^f\b\s*(.*)/ && do {
- $file = $1;
- $file =~ s/\s+$//;
- if (!$file) {
- print $OUT "The old f command is now the r command.\n"; # hint
- print $OUT "The new f command switches filenames.\n";
- next CMD;
- }
- if (!defined $main::{'_<' . $file}) {
- if (($try) = grep(m#^_<.*$file#, keys %main::)) {{
- $try = substr($try,2);
- print $OUT "Choosing $try matching `$file':\n";
- $file = $try;
- }}
- }
- if (!defined $main::{'_<' . $file}) {
- print $OUT "No file matching `$file' is loaded.\n";
- next CMD;
- } elsif ($file ne $filename) {
- *dbline = $main::{'_<' . $file};
- $max = $#dbline;
- $filename = $file;
- $start = 1;
- $cmd = "l";
- } else {
- print $OUT "Already in $file.\n";
- next CMD;
- }
- };
- $cmd =~ /^\.$/ && do {
- $incr = -1; # for backward motion.
- $start = $line;
- $filename = $filename_ini;
- *dbline = $main::{'_<' . $filename};
- $max = $#dbline;
- print_lineinfo($position);
- next CMD };
- $cmd =~ /^-$/ && do {
- $start -= $incr + $window + 1;
- $start = 1 if $start <= 0;
- $incr = $window - 1;
- $cmd = 'l ' . ($start) . '+'; };
- # rjsf ->
- $cmd =~ /^([aAbBhlLMoOPvwW]\b|[<>\{]{1,2})\s*(.*)/so && do {
- &cmd_wrapper($1, $2, $line);
- next CMD;
- };
- # rjsf <- pre|post commands stripped out
- $cmd =~ /^y(?:\s+(\d*)\s*(.*))?$/ && do {
- eval { require PadWalker; PadWalker->VERSION(0.08) }
- or &warn($@ =~ /locate/
- ? "PadWalker module not found - please install\n"
- : $@)
- and next CMD;
- do 'dumpvar.pl' unless defined &main::dumpvar;
- defined &main::dumpvar
- or print $OUT "dumpvar.pl not available.\n"
- and next CMD;
- my @vars = split(' ', $2 || '');
- my $h = eval { PadWalker::peek_my(($1 || 0) + 1) };
- $@ and $@ =~ s/ at .*//, &warn($@), next CMD;
- my $savout = select($OUT);
- dumpvar::dumplex($_, $h->{$_},
- defined $option{dumpDepth}
- ? $option{dumpDepth} : -1,
- @vars)
- for sort keys %$h;
- select($savout);
- next CMD; };
- $cmd =~ /^n$/ && do {
- end_report(), next CMD if $finished and $level <= 1;
- $single = 2;
- $laststep = $cmd;
- last CMD; };
- $cmd =~ /^s$/ && do {
- end_report(), next CMD if $finished and $level <= 1;
- $single = 1;
- $laststep = $cmd;
- last CMD; };
- $cmd =~ /^c\b\s*([\w:]*)\s*$/ && do {
- end_report(), next CMD if $finished and $level <= 1;
- $subname = $i = $1;
- # Probably not needed, since we finish an interactive
- # sub-session anyway...
- # local $filename = $filename;
- # local *dbline = *dbline; # XXX Would this work?!
- if ($subname =~ /\D/) { # subroutine name
- $subname = $package."::".$subname
- unless $subname =~ /::/;
- ($file,$i) = (find_sub($subname) =~ /^(.*):(.*)$/);
- $i += 0;
- if ($i) {
- $filename = $file;
- *dbline = $main::{'_<' . $filename};
- $had_breakpoints{$filename} |= 1;
- $max = $#dbline;
- ++$i while $dbline[$i] == 0 && $i < $max;
- } else {
- print $OUT "Subroutine $subname not found.\n";
- next CMD;
- }
- }
- if ($i) {
- if ($dbline[$i] == 0) {
- print $OUT "Line $i not breakable.\n";
- next CMD;
- }
- $dbline{$i} =~ s/($|\0)/;9$1/; # add one-time-only b.p.
- }
- for ($i=0; $i <= $stack_depth; ) {
- $stack[$i++] &= ~1;
- }
- last CMD; };
- $cmd =~ /^r$/ && do {
- end_report(), next CMD if $finished and $level <= 1;
- $stack[$stack_depth] |= 1;
- $doret = $option{PrintRet} ? $stack_depth - 1 : -2;
- last CMD; };
- $cmd =~ /^R$/ && do {
- print $OUT "Warning: some settings and command-line options may be lost!\n";
- my (@script, @flags, $cl);
- push @flags, '-w' if $ini_warn;
- if ($ini_assertion and @{^ASSERTING}) {
- push @flags, (map { /\:\^\(\?\:(.*)\)\$\)/ ?
- "-A$1" : "-A$_" } @{^ASSERTING});
- }
- # Put all the old includes at the start to get
- # the same debugger.
- for (@ini_INC) {
- push @flags, '-I', $_;
- }
- push @flags, '-T' if ${^TAINT};
- # Arrange for setting the old INC:
- set_list("PERLDB_INC", @ini_INC);
- if ($0 eq '-e') {
- for (1..$#{'::_<-e'}) { # The first line is PERL5DB
- chomp ($cl = ${'::_<-e'}[$_]);
- push @script, '-e', $cl;
- }
- } else {
- @script = $0;
- }
- set_list("PERLDB_HIST",
- $term->Features->{getHistory}
- ? $term->GetHistory : @hist);
- my @had_breakpoints = keys %had_breakpoints;
- set_list("PERLDB_VISITED", @had_breakpoints);
- set_list("PERLDB_OPT", options2remember());
- set_list("PERLDB_ON_LOAD", %break_on_load);
- my @hard;
- for (0 .. $#had_breakpoints) {
- my $file = $had_breakpoints[$_];
- *dbline = $main::{'_<' . $file};
- next unless %dbline or $postponed_file{$file};
- (push @hard, $file), next
- if $file =~ /^\(\w*eval/;
- my @add;
- @add = %{$postponed_file{$file}}
- if $postponed_file{$file};
- set_list("PERLDB_FILE_$_", %dbline, @add);
- }
- for (@hard) { # Yes, really-really...
- # Find the subroutines in this eval
- *dbline = $main::{'_<' . $_};
- my ($quoted, $sub, %subs, $line) = quotemeta $_;
- for $sub (keys %sub) {
- next unless $sub{$sub} =~ /^$quoted:(\d+)-(\d+)$/;
- $subs{$sub} = [$1, $2];
- }
- unless (%subs) {
- print $OUT
- "No subroutines in $_, ignoring breakpoints.\n";
- next;
- }
- LINES: for $line (keys %dbline) {
- # One breakpoint per sub only:
- my ($offset, $sub, $found);
- SUBS: for $sub (keys %subs) {
- if ($subs{$sub}->[1] >= $line # Not after the subroutine
- and (not defined $offset # Not caught
- or $offset < 0 )) { # or badly caught
- $found = $sub;
- $offset = $line - $subs{$sub}->[0];
- $offset = "+$offset", last SUBS if $offset >= 0;
- }
- }
- if (defined $offset) {
- $postponed{$found} =
- "break $offset if $dbline{$line}";
- } else {
- print $OUT "Breakpoint in $_:$line ignored: after all the subroutines.\n";
- }
- }
- }
- set_list("PERLDB_POSTPONE", %postponed);
- set_list("PERLDB_PRETYPE", @$pretype);
- set_list("PERLDB_PRE", @$pre);
- set_list("PERLDB_POST", @$post);
- set_list("PERLDB_TYPEAHEAD", @typeahead);
- $ENV{PERLDB_RESTART} = 1;
- delete $ENV{PERLDB_PIDS}; # Restore ini state
- $ENV{PERLDB_PIDS} = $ini_pids if defined $ini_pids;
- #print "$^X, '-d', @flags, @script, ($slave_editor ? '-emacs' : ()), @ARGS";
- exec($^X, '-d', @flags, @script, ($slave_editor ? '-emacs' : ()), @ARGS) ||
- print $OUT "exec failed: $!\n";
- last CMD; };
- $cmd =~ /^T$/ && do {
- print_trace($OUT, 1); # skip DB
- next CMD; };
- $cmd =~ /^w\b\s*(.*)/s && do { &cmd_w('w', $1); next CMD; };
- $cmd =~ /^W\b\s*(.*)/s && do { &cmd_W('W', $1); next CMD; };
- $cmd =~ /^\/(.*)$/ && do {
- $inpat = $1;
- $inpat =~ s:([^\\])/$:$1:;
- if ($inpat ne "") {
- # squelch the sigmangler
- local $SIG{__DIE__};
- local $SIG{__WARN__};
- eval '$inpat =~ m'."\a$inpat\a";
- if ($@ ne "") {
- print $OUT "$@";
- next CMD;
- }
- $pat = $inpat;
- }
- $end = $start;
- $incr = -1;
- eval '
- for (;;) {
- ++$start;
- $start = 1 if ($start > $max);
- last if ($start == $end);
- if ($dbline[$start] =~ m' . "\a$pat\a" . 'i) {
- if ($slave_editor) {
- print $OUT "\032\032$filename:$start:0\n";
- } else {
- print $OUT "$start:\t", $dbline[$start], "\n";
- }
- last;
- }
- } ';
- print $OUT "/$pat/: not found\n" if ($start == $end);
- next CMD; };
- $cmd =~ /^\?(.*)$/ && do {
- $inpat = $1;
- $inpat =~ s:([^\\])\?$:$1:;
- if ($inpat ne "") {
- # squelch the sigmangler
- local $SIG{__DIE__};
- local $SIG{__WARN__};
- eval '$inpat =~ m'."\a$inpat\a";
- if ($@ ne "") {
- print $OUT $@;
- next CMD;
- }
- $pat = $inpat;
- }
- $end = $start;
- $incr = -1;
- eval '
- for (;;) {
- --$start;
- $start = $max if ($start <= 0);
- last if ($start == $end);
- if ($dbline[$start] =~ m' . "\a$pat\a" . 'i) {
- if ($slave_editor) {
- print $OUT "\032\032$filename:$start:0\n";
- } else {
- print $OUT "$start:\t", $dbline[$start], "\n";
- }
- last;
- }
- } ';
- print $OUT "?$pat?: not found\n" if ($start == $end);
- next CMD; };
- $cmd =~ /^$rc+\s*(-)?(\d+)?$/ && do {
- pop(@hist) if length($cmd) > 1;
- $i = $1 ? ($#hist-($2||1)) : ($2||$#hist);
- $cmd = $hist[$i];
- print $OUT $cmd, "\n";
- redo CMD; };
- $cmd =~ /^$sh$sh\s*([\x00-\xff]*)/ && do {
- &system($1);
- next CMD; };
- $cmd =~ /^$rc([^$rc].*)$/ && do {
- $pat = "^$1";
- pop(@hist) if length($cmd) > 1;
- for ($i = $#hist; $i; --$i) {
- last if $hist[$i] =~ /$pat/;
- }
- if (!$i) {
- print $OUT "No such command!\n\n";
- next CMD;
- }
- $cmd = $hist[$i];
- print $OUT $cmd, "\n";
- redo CMD; };
- $cmd =~ /^$sh$/ && do {
- &system($ENV{SHELL}||"/bin/sh");
- next CMD; };
- $cmd =~ /^$sh\s*([\x00-\xff]*)/ && do {
- # XXX: using csh or tcsh destroys sigint retvals!
- #&system($1); # use this instead
- &system($ENV{SHELL}||"/bin/sh","-c",$1);
- next CMD; };
- $cmd =~ /^H\b\s*(-(\d+))?/ && do {
- $end = $2 ? ($#hist-$2) : 0;
- $hist = 0 if $hist < 0;
- for ($i=$#hist; $i>$end; $i--) {
- print $OUT "$i: ",$hist[$i],"\n"
- unless $hist[$i] =~ /^.?$/;
- };
- next CMD; };
- $cmd =~ /^(?:man|(?:perl)?doc)\b(?:\s+([^(]*))?$/ && do {
- runman($1);
- next CMD; };
- $cmd =~ s/^p$/print {\$DB::OUT} \$_/;
- $cmd =~ s/^p\b/print {\$DB::OUT} /;
- $cmd =~ s/^=\s*// && do {
- my @keys;
- if (length $cmd == 0) {
- @keys = sort keys %alias;
- } elsif (my($k,$v) = ($cmd =~ /^(\S+)\s+(\S.*)/)) {
- # can't use $_ or kill //g state
- for my $x ($k, $v) { $x =~ s/\a/\\a/g }
- $alias{$k} = "s\a$k\a$v\a";
- # squelch the sigmangler
- local $SIG{__DIE__};
- local $SIG{__WARN__};
- unless (eval "sub { s\a$k\a$v\a }; 1") {
- print $OUT "Can't alias $k to $v: $@\n";
- delete $alias{$k};
- next CMD;
- }
- @keys = ($k);
- } else {
- @keys = ($cmd);
- }
- for my $k (@keys) {
- if ((my $v = $alias{$k}) =~ s\as\a$k\a(.*)\a$\a1\a) {
- print $OUT "$k\t= $1\n";
- }
- elsif (defined $alias{$k}) {
- print $OUT "$k\t$alias{$k}\n";
- }
- else {
- print "No alias for $k\n";
- }
- }
- next CMD; };
- $cmd =~ /^source\s+(.*\S)/ && do {
- if (open my $fh, $1) {
- push @cmdfhs, $fh;
- } else {
- &warn("Can't execute `$1': $!\n");
- }
- next CMD; };
- $cmd =~ /^\|\|?\s*[^|]/ && do {
- if ($pager =~ /^\|/) {
- open(SAVEOUT,">&STDOUT") || &warn("Can't save STDOUT");
- open(STDOUT,">&OUT") || &warn("Can't redirect STDOUT");
- } else {
- open(SAVEOUT,">&OUT") || &warn("Can't save DB::OUT");
- }
- fix_less();
- unless ($piped=open(OUT,$pager)) {
- &warn("Can't pipe output to `$pager'");
- if ($pager =~ /^\|/) {
- open(OUT,">&STDOUT") # XXX: lost message
- || &warn("Can't restore DB::OUT");
- open(STDOUT,">&SAVEOUT")
- || &warn("Can't restore STDOUT");
- close(SAVEOUT);
- } else {
- open(OUT,">&STDOUT") # XXX: lost message
- || &warn("Can't restore DB::OUT");
- }
- next CMD;
- }
- $SIG{PIPE}= \&DB::catch if $pager =~ /^\|/
- && ("" eq $SIG{PIPE} || "DEFAULT" eq $SIG{PIPE});
- $selected= select(OUT);
- $|= 1;
- select( $selected ), $selected= "" unless $cmd =~ /^\|\|/;
- $cmd =~ s/^\|+\s*//;
- redo PIPE;
- };
- # XXX Local variants do not work!
- $cmd =~ s/^t\s/\$DB::trace |= 1;\n/;
- $cmd =~ s/^s\s/\$DB::single = 1;\n/ && do {$laststep = 's'};
- $cmd =~ s/^n\s/\$DB::single = 2;\n/ && do {$laststep = 'n'};
- } # PIPE:
- $evalarg = "\$^D = \$^D | \$DB::db_stop;\n$cmd"; &eval;
- if ($onetimeDump) {
- $onetimeDump = undef;
- $onetimedumpDepth = undef;
- } elsif ($term_pid == $$) {
- print $OUT "\n";
- }
- } continue { # CMD:
- if ($piped) {
- if ($pager =~ /^\|/) {
- $? = 0;
- # we cannot warn here: the handle is missing --tchrist
- close(OUT) || print SAVEOUT "\nCan't close DB::OUT\n";
-
- # most of the $? crud was coping with broken cshisms
- if ($?) {
- print SAVEOUT "Pager `$pager' failed: ";
- if ($? == -1) {
- print SAVEOUT "shell returned -1\n";
- } elsif ($? >> 8) {
- print SAVEOUT
- ( $? & 127 ) ? " (SIG#".($?&127).")" : "",
- ( $? & 128 ) ? " -- core dumped" : "", "\n";
- } else {
- print SAVEOUT "status ", ($? >> 8), "\n";
- }
- }
-
- open(OUT,">&STDOUT") || &warn("Can't restore DB::OUT");
- open(STDOUT,">&SAVEOUT") || &warn("Can't restore STDOUT");
- $SIG{PIPE} = "DEFAULT" if $SIG{PIPE} eq \&DB::catch;
- # Will stop ignoring SIGPIPE if done like nohup(1)
- # does SIGINT but Perl doesn't give us a choice.
- } else {
- open(OUT,">&SAVEOUT") || &warn("Can't restore DB::OUT");
- }
- close(SAVEOUT);
- select($selected), $selected= "" unless $selected eq "";
- $piped= "";
- }
- } # CMD:
- $fall_off_end = 1 unless defined $cmd; # Emulate `q' on EOF
- foreach $evalarg (@$post) {
- &eval;
- }
- } # if ($single || $signal)
- ($@, $!, $^E, $,, $/, $\, $^W) = @saved;
- ();
-}
+ # Yes, go down a level.
+ local $level = $level + 1;
-# The following code may be executed now:
-# BEGIN {warn 4}
+ # Do any pre-prompt actions.
+ foreach $evalarg (@$pre) {
+ &eval;
+ }
-sub sub {
- my ($al, $ret, @ret) = "";
- if (length($sub) > 10 && substr($sub, -10, 10) eq '::AUTOLOAD') {
- $al = " for $$sub";
- }
- local $stack_depth = $stack_depth + 1; # Protect from non-local exits
- $#stack = $stack_depth;
- $stack[-1] = $single;
- $single &= 1;
- $single |= 4 if $stack_depth == $deep;
- ($frame & 4
- ? ( print_lineinfo(' ' x ($stack_depth - 1), "in "),
- # Why -1? But it works! :-(
- print_trace($LINEINFO, -1, 1, 1, "$sub$al") )
- : print_lineinfo(' ' x ($stack_depth - 1), "entering $sub$al\n")) if $frame;
- if (wantarray) {
- if ($assertion) {
- $assertion=0;
- eval {
- @ret = &$sub;
- };
- if ($@) {
- print $OUT $@;
- $signal=1 unless $warnassertions;
- }
- }
- else {
- @ret = &$sub;
- }
- $single |= $stack[$stack_depth--];
- ($frame & 4
- ? ( print_lineinfo(' ' x $stack_depth, "out "),
- print_trace($LINEINFO, -1, 1, 1, "$sub$al") )
- : print_lineinfo(' ' x $stack_depth, "exited $sub$al\n")) if $frame & 2;
- if ($doret eq $stack_depth or $frame & 16) {
- local $\ = '';
- my $fh = ($doret eq $stack_depth ? $OUT : $LINEINFO);
- print $fh ' ' x $stack_depth if $frame & 16;
- print $fh "list context return from $sub:\n";
- dumpit($fh, \@ret );
- $doret = -2;
- }
- @ret;
- } else {
- if ($assertion) {
- $assertion=0;
- eval {
- $ret = &$sub;
- };
- if ($@) {
- print $OUT $@;
- $signal=1 unless $warnassertions;
- }
- $ret=undef unless defined wantarray;
- }
- else {
- if (defined wantarray) {
- $ret = &$sub;
- } else {
- &$sub; undef $ret;
- }
- }
- $single |= $stack[$stack_depth--];
- ($frame & 4
- ? ( print_lineinfo(' ' x $stack_depth, "out "),
- print_trace($LINEINFO, -1, 1, 1, "$sub$al") )
- : print_lineinfo(' ' x $stack_depth, "exited $sub$al\n")) if $frame & 2;
- if ($doret eq $stack_depth or $frame & 16 and defined wantarray) {
- local $\ = '';
- my $fh = ($doret eq $stack_depth ? $OUT : $LINEINFO);
- print $fh (' ' x $stack_depth) if $frame & 16;
- print $fh (defined wantarray
- ? "scalar context return from $sub: "
- : "void context return from $sub\n");
- dumpit( $fh, $ret ) if defined wantarray;
- $doret = -2;
- }
- $ret;
- }
-}
+ # Complain about too much recursion if we passed the limit.
+ print $OUT $stack_depth . " levels deep in subroutine calls!\n"
+ if $single & 4;
-### The API section
+ # The line we're currently on. Set $incr to -1 to stay here
+ # until we get a command that tells us to advance.
+ $start = $line;
+ $incr = -1; # for backward motion.
-### Functions with multiple modes of failure die on error, the rest
-### returns FALSE on error.
-### User-interface functions cmd_* output error message.
-
-### Note all cmd_[a-zA-Z]'s require $cmd, $line, $dblineno as first arguments
-
-my %set = ( #
- 'pre580' => {
- 'a' => 'pre580_a',
- 'A' => 'pre580_null',
- 'b' => 'pre580_b',
- 'B' => 'pre580_null',
- 'd' => 'pre580_null',
- 'D' => 'pre580_D',
- 'h' => 'pre580_h',
- 'M' => 'pre580_null',
- 'O' => 'o',
- 'o' => 'pre580_null',
- 'v' => 'M',
- 'w' => 'v',
- 'W' => 'pre580_W',
- },
- 'pre590' => {
- '<' => 'pre590_prepost',
- '<<' => 'pre590_prepost',
- '>' => 'pre590_prepost',
- '>>' => 'pre590_prepost',
- '{' => 'pre590_prepost',
- '{{' => 'pre590_prepost',
- },
-);
+ # Tack preprompt debugger actions ahead of any actual input.
+ @typeahead = (@$pretype, @typeahead);
-sub cmd_wrapper {
- my $cmd = shift;
- my $line = shift;
- my $dblineno = shift;
-
- # with this level of indirection we can wrap
- # to old (pre580) or other command sets easily
- #
- my $call = 'cmd_'.(
- $set{$CommandSet}{$cmd} || ($cmd =~ /^[<>{]+/o ? 'prepost' : $cmd)
- );
- # print "cmd_wrapper($cmd): $CommandSet($set{$CommandSet}{$cmd}) => call($call)\n";
-
- return &$call($cmd, $line, $dblineno);
-}
+=head2 WHERE ARE WE?
-sub cmd_a {
- my $cmd = shift; # a
- my $line = shift || ''; # [.|line] expr
- my $dbline = shift; $line =~ s/^(\.|(?:[^\d]))/$dbline/;
- if ($line =~ /^\s*(\d*)\s*(\S.+)/) {
- my ($lineno, $expr) = ($1, $2);
- if (length $expr) {
- if ($dbline[$lineno] == 0) {
- print $OUT "Line $lineno($dbline[$lineno]) does not have an action?\n";
- } else {
- $had_breakpoints{$filename} |= 2;
- $dbline{$lineno} =~ s/\0[^\0]*//;
- $dbline{$lineno} .= "\0" . action($expr);
- }
- }
- } else {
- print $OUT "Adding an action requires an optional lineno and an expression\n"; # hint
- }
-}
+XXX Relocate this section?
-sub cmd_A {
- my $cmd = shift; # A
- my $line = shift || '';
- my $dbline = shift; $line =~ s/^\./$dbline/;
- if ($line eq '*') {
- eval { &delete_action(); 1 } or print $OUT $@ and return;
- } elsif ($line =~ /^(\S.*)/) {
- eval { &delete_action($1); 1 } or print $OUT $@ and return;
- } else {
- print $OUT "Deleting an action requires a line number, or '*' for all\n"; # hint
- }
-}
+The debugger normally shows the line corresponding to the current line of
+execution. Sometimes, though, we want to see the next line, or to move elsewhere
+in the file. This is done via the C<$incr>, C<$start>, and C<$max> variables.
-sub delete_action {
- my $i = shift;
- if (defined($i)) {
- die "Line $i has no action .\n" if $dbline[$i] == 0;
- $dbline{$i} =~ s/\0[^\0]*//; # \^a
- delete $dbline{$i} if $dbline{$i} eq '';
- } else {
- print $OUT "Deleting all actions...\n";
- for my $file (keys %had_breakpoints) {
- local *dbline = $main::{'_<' . $file};
- my $max = $#dbline;
- my $was;
- for ($i = 1; $i <= $max ; $i++) {
- if (defined $dbline{$i}) {
- $dbline{$i} =~ s/\0[^\0]*//;
- delete $dbline{$i} if $dbline{$i} eq '';
- }
- unless ($had_breakpoints{$file} &= ~2) {
- delete $had_breakpoints{$file};
- }
- }
- }
- }
-}
+C<$incr> controls by how many lines the "current" line should move forward
+after a command is executed. If set to -1, this indicates that the "current"
+line shouldn't change.
-sub cmd_b {
- my $cmd = shift; # b
- my $line = shift; # [.|line] [cond]
- my $dbline = shift; $line =~ s/^\./$dbline/;
- if ($line =~ /^\s*$/) {
- &cmd_b_line($dbline, 1);
- } elsif ($line =~ /^load\b\s*(.*)/) {
- my $file = $1; $file =~ s/\s+$//;
- &cmd_b_load($file);
- } elsif ($line =~ /^(postpone|compile)\b\s*([':A-Za-z_][':\w]*)\s*(.*)/) {
- my $cond = length $3 ? $3 : '1';
- my ($subname, $break) = ($2, $1 eq 'postpone');
- $subname =~ s/\'/::/g;
- $subname = "${'package'}::" . $subname unless $subname =~ /::/;
- $subname = "main".$subname if substr($subname,0,2) eq "::";
- $postponed{$subname} = $break ? "break +0 if $cond" : "compile";
- } elsif ($line =~ /^([':A-Za-z_][':\w]*(?:\[.*\])?)\s*(.*)/) {
- $subname = $1;
- $cond = length $2 ? $2 : '1';
- &cmd_b_sub($subname, $cond);
- } elsif ($line =~ /^(\d*)\s*(.*)/) {
- $line = $1 || $dbline;
- $cond = length $2 ? $2 : '1';
- &cmd_b_line($line, $cond);
- } else {
- print "confused by line($line)?\n";
- }
-}
+C<$start> is the "current" line. It is used for things like knowing where to
+move forwards or backwards from when doing an C<L> or C<-> command.
-sub break_on_load {
- my $file = shift;
- $break_on_load{$file} = 1;
- $had_breakpoints{$file} |= 1;
-}
+C<$max> tells the debugger where the last line of the current file is. It's
+used to terminate loops most often.
-sub report_break_on_load {
- sort keys %break_on_load;
-}
+=head2 THE COMMAND LOOP
-sub cmd_b_load {
- my $file = shift;
- my @files;
- {
- push @files, $file;
- push @files, $::INC{$file} if $::INC{$file};
- $file .= '.pm', redo unless $file =~ /\./;
- }
- break_on_load($_) for @files;
- @files = report_break_on_load;
- local $\ = '';
- local $" = ' ';
- print $OUT "Will stop on load of `@files'.\n";
-}
+Most of C<DB::DB> is actually a command parsing and dispatch loop. It comes
+in two parts:
-$filename_error = '';
+=over 4
-sub breakable_line {
- my ($from, $to) = @_;
- my $i = $from;
- if (@_ >= 2) {
- my $delta = $from < $to ? +1 : -1;
- my $limit = $delta > 0 ? $#dbline : 1;
- $limit = $to if ($limit - $to) * $delta > 0;
- $i += $delta while $dbline[$i] == 0 and ($limit - $i) * $delta > 0;
- }
- return $i unless $dbline[$i] == 0;
- my ($pl, $upto) = ('', '');
- ($pl, $upto) = ('s', "..$to") if @_ >=2 and $from != $to;
- die "Line$pl $from$upto$filename_error not breakable\n";
-}
+=item * The outer part of the loop, starting at the C<CMD> label. This loop
+reads a command and then executes it.
-sub breakable_line_in_filename {
- my ($f) = shift;
- local *dbline = $main::{'_<' . $f};
- local $filename_error = " of `$f'";
- breakable_line(@_);
-}
+=item * The inner part of the loop, starting at the C<PIPE> label. This part
+is wholly contained inside the C<CMD> block and only executes a command.
+Used to handle commands running inside a pager.
-sub break_on_line {
- my ($i, $cond) = @_;
- $cond = 1 unless @_ >= 2;
- my $inii = $i;
- my $after = '';
- my $pl = '';
- die "Line $i$filename_error not breakable.\n" if $dbline[$i] == 0;
- $had_breakpoints{$filename} |= 1;
- if ($dbline{$i}) { $dbline{$i} =~ s/^[^\0]*/$cond/; }
- else { $dbline{$i} = $cond; }
-}
+=back
-sub cmd_b_line {
- eval { break_on_line(@_); 1 } or do {
- local $\ = '';
- print $OUT $@ and return;
- };
-}
+So why have two labels to restart the loop? Because sometimes, it's easier to
+have a command I<generate> another command and then re-execute the loop to do
+the new command. This is faster, but perhaps a bit more convoluted.
-sub break_on_filename_line {
- my ($f, $i, $cond) = @_;
- $cond = 1 unless @_ >= 3;
- local *dbline = $main::{'_<' . $f};
- local $filename_error = " of `$f'";
- local $filename = $f;
- break_on_line($i, $cond);
-}
+=cut
-sub break_on_filename_line_range {
- my ($f, $from, $to, $cond) = @_;
- my $i = breakable_line_in_filename($f, $from, $to);
- $cond = 1 unless @_ >= 3;
- break_on_filename_line($f,$i,$cond);
-}
+ # The big command dispatch loop. It keeps running until the
+ # user yields up control again.
+ #
+ # If we have a terminal for input, and we get something back
+ # from readline(), keep on processing.
+ CMD:
+ while (
+ # We have a terminal, or can get one ...
+ ($term || &setterm),
+ # ... and it belogs to this PID or we get one for this PID ...
+ ($term_pid == $$ or resetterm(1)),
+ # ... and we got a line of command input ...
+ defined(
+ $cmd = &readline(
+ "$pidprompt DB" . ('<' x $level) . ($#hist + 1) .
+ ('>' x $level) . " "
+ )
+ )
+ )
+ {
+ # ... try to execute the input as debugger commands.
-sub subroutine_filename_lines {
- my ($subname,$cond) = @_;
- # Filename below can contain ':'
- find_sub($subname) =~ /^(.*):(\d+)-(\d+)$/;
-}
+ # Don't stop running.
+ $single = 0;
-sub break_subroutine {
- my $subname = shift;
- my ($file,$s,$e) = subroutine_filename_lines($subname) or
- die "Subroutine $subname not found.\n";
- $cond = 1 unless @_ >= 2;
- break_on_filename_line_range($file,$s,$e,@_);
-}
+ # No signal is active.
+ $signal = 0;
-sub cmd_b_sub {
- my ($subname,$cond) = @_;
- $cond = 1 unless @_ >= 2;
- unless (ref $subname eq 'CODE') {
- $subname =~ s/\'/::/g;
- my $s = $subname;
- $subname = "${'package'}::" . $subname
- unless $subname =~ /::/;
- $subname = "CORE::GLOBAL::$s"
- if not defined &$subname and $s !~ /::/ and defined &{"CORE::GLOBAL::$s"};
- $subname = "main".$subname if substr($subname,0,2) eq "::";
- }
- eval { break_subroutine($subname,$cond); 1 } or do {
- local $\ = '';
- print $OUT $@ and return;
- }
-}
+ # Handle continued commands (ending with \):
+ $cmd =~ s/\\$/\n/ && do {
+ $cmd .= &readline(" cont: ");
+ redo CMD;
+ };
-sub cmd_B {
- my $cmd = shift; # B
- my $line = ($_[0] =~ /^\./) ? $dbline : shift || '';
- my $dbline = shift; $line =~ s/^\./$dbline/;
- if ($line eq '*') {
- eval { &delete_breakpoint(); 1 } or print $OUT $@ and return;
- } elsif ($line =~ /^(\S.*)/) {
- eval { &delete_breakpoint($line || $dbline); 1 } or do {
- local $\ = '';
- print $OUT $@ and return;
- };
- } else {
- print $OUT "Deleting a breakpoint requires a line number, or '*' for all\n"; # hint
- }
-}
+=head4 The null command
-sub delete_breakpoint {
- my $i = shift;
- if (defined($i)) {
- die "Line $i not breakable.\n" if $dbline[$i] == 0;
- $dbline{$i} =~ s/^[^\0]*//;
- delete $dbline{$i} if $dbline{$i} eq '';
- } else {
- print $OUT "Deleting all breakpoints...\n";
- for my $file (keys %had_breakpoints) {
- local *dbline = $main::{'_<' . $file};
- my $max = $#dbline;
- my $was;
- for ($i = 1; $i <= $max ; $i++) {
- if (defined $dbline{$i}) {
- $dbline{$i} =~ s/^[^\0]+//;
- if ($dbline{$i} =~ s/^\0?$//) {
- delete $dbline{$i};
- }
- }
- }
- if (not $had_breakpoints{$file} &= ~1) {
- delete $had_breakpoints{$file};
- }
- }
- undef %postponed;
- undef %postponed_file;
- undef %break_on_load;
- }
-}
+A newline entered by itself means "re-execute the last command". We grab the
+command out of C<$laststep> (where it was recorded previously), and copy it
+back into C<$cmd> to be executed below. If there wasn't any previous command,
+we'll do nothing below (no command will match). If there was, we also save it
+in the command history and fall through to allow the command parsing to pick
+it up.
-sub cmd_stop { # As on ^C, but not signal-safy.
- $signal = 1;
-}
+=cut
-sub cmd_h {
- my $cmd = shift; # h
- my $line = shift || '';
- if ($line =~ /^h\s*/) {
- print_help($help);
- } elsif ($line =~ /^(\S.*)$/) {
- # support long commands; otherwise bogus errors
- # happen when you ask for h on <CR> for example
- my $asked = $1; # for proper errmsg
- my $qasked = quotemeta($asked); # for searching
- # XXX: finds CR but not <CR>
- if ($help =~ /^<?(?:[IB]<)$qasked/m) {
- while ($help =~ /^(<?(?:[IB]<)$qasked([\s\S]*?)\n)(?!\s)/mg) {
- print_help($1);
- }
- } else {
- print_help("B<$asked> is not a debugger command.\n");
- }
- } else {
- print_help($summary);
- }
-}
+ # Empty input means repeat the last command.
+ $cmd =~ /^$/ && ($cmd = $laststep);
+ push (@hist, $cmd) if length($cmd) > 1;
-sub cmd_l {
- my $current_line = $line;
- my $cmd = shift; # l
- my $line = shift;
- $line =~ s/^-\s*$/-/;
- if ($line =~ /^(\$.*)/s) {
- $evalarg = $2;
- my ($s) = &eval;
- print($OUT "Error: $@\n"), next CMD if $@;
- $s = CvGV_name($s);
- print($OUT "Interpreted as: $1 $s\n");
- $line = "$1 $s";
- &cmd_l('l', $s);
- } elsif ($line =~ /^([\':A-Za-z_][\':\w]*(\[.*\])?)/s) {
- my $s = $subname = $1;
- $subname =~ s/\'/::/;
- $subname = $package."::".$subname
- unless $subname =~ /::/;
- $subname = "CORE::GLOBAL::$s"
- if not defined &$subname and $s !~ /::/
- and defined &{"CORE::GLOBAL::$s"};
- $subname = "main".$subname if substr($subname,0,2) eq "::";
- @pieces = split(/:/,find_sub($subname) || $sub{$subname});
- $subrange = pop @pieces;
- $file = join(':', @pieces);
- if ($file ne $filename) {
- print $OUT "Switching to file '$file'.\n"
- unless $slave_editor;
- *dbline = $main::{'_<' . $file};
- $max = $#dbline;
- $filename = $file;
- }
- if ($subrange) {
- if (eval($subrange) < -$window) {
- $subrange =~ s/-.*/+/;
- }
- $line = $subrange;
- &cmd_l('l', $subrange);
- } else {
- print $OUT "Subroutine $subname not found.\n";
- }
- } elsif ($line =~ /^\s*$/) {
- $incr = $window - 1;
- $line = $start . '-' . ($start + $incr);
- &cmd_l('l', $line);
- } elsif ($line =~ /^(\d*)\+(\d*)$/) {
- $start = $1 if $1;
- $incr = $2;
- $incr = $window - 1 unless $incr;
- $line = $start . '-' . ($start + $incr);
- &cmd_l('l', $line);
- } elsif ($line =~ /^((-?[\d\$\.]+)([-,]([\d\$\.]+))?)?/) {
- $end = (!defined $2) ? $max : ($4 ? $4 : $2);
- $end = $max if $end > $max;
- $i = $2;
- $i = $line if $i eq '.';
- $i = 1 if $i < 1;
- $incr = $end - $i;
- if ($slave_editor) {
- print $OUT "\032\032$filename:$i:0\n";
- $i = $end;
- } else {
- for (; $i <= $end; $i++) {
- my ($stop,$action);
- ($stop,$action) = split(/\0/, $dbline{$i}) if
- $dbline{$i};
- $arrow = ($i==$current_line
- and $filename eq $filename_ini)
- ? '==>'
- : ($dbline[$i]+0 ? ':' : ' ') ;
- $arrow .= 'b' if $stop;
- $arrow .= 'a' if $action;
- print $OUT "$i$arrow\t", $dbline[$i];
- $i++, last if $signal;
- }
- print $OUT "\n" unless $dbline[$i-1] =~ /\n$/;
- }
- $start = $i; # remember in case they want more
- $start = $max if $start > $max;
- }
-}
-sub cmd_L {
- my $cmd = shift; # L
- my $arg = shift || 'abw'; $arg = 'abw' unless $CommandSet eq '580'; # sigh...
- my $action_wanted = ($arg =~ /a/) ? 1 : 0;
- my $break_wanted = ($arg =~ /b/) ? 1 : 0;
- my $watch_wanted = ($arg =~ /w/) ? 1 : 0;
-
- if ($break_wanted or $action_wanted) {
- for my $file (keys %had_breakpoints) {
- local *dbline = $main::{'_<' . $file};
- my $max = $#dbline;
- my $was;
- for ($i = 1; $i <= $max; $i++) {
- if (defined $dbline{$i}) {
- print $OUT "$file:\n" unless $was++;
- print $OUT " $i:\t", $dbline[$i];
- ($stop,$action) = split(/\0/, $dbline{$i});
- print $OUT " break if (", $stop, ")\n"
- if $stop and $break_wanted;
- print $OUT " action: ", $action, "\n"
- if $action and $action_wanted;
- last if $signal;
- }
- }
- }
- }
- if (%postponed and $break_wanted) {
- print $OUT "Postponed breakpoints in subroutines:\n";
- my $subname;
- for $subname (keys %postponed) {
- print $OUT " $subname\t$postponed{$subname}\n";
- last if $signal;
- }
- }
- my @have = map { # Combined keys
- keys %{$postponed_file{$_}}
- } keys %postponed_file;
- if (@have and ($break_wanted or $action_wanted)) {
- print $OUT "Postponed breakpoints in files:\n";
- my ($file, $line);
- for $file (keys %postponed_file) {
- my $db = $postponed_file{$file};
- print $OUT " $file:\n";
- for $line (sort {$a <=> $b} keys %$db) {
- print $OUT " $line:\n";
- my ($stop,$action) = split(/\0/, $$db{$line});
- print $OUT " break if (", $stop, ")\n"
- if $stop and $break_wanted;
- print $OUT " action: ", $action, "\n"
- if $action and $action_wanted;
- last if $signal;
- }
- last if $signal;
- }
- }
- if (%break_on_load and $break_wanted) {
- print $OUT "Breakpoints on load:\n";
- my $file;
- for $file (keys %break_on_load) {
- print $OUT " $file\n";
- last if $signal;
- }
- }
- if ($watch_wanted) {
- if ($trace & 2) {
- print $OUT "Watch-expressions:\n" if @to_watch;
- for my $expr (@to_watch) {
- print $OUT " $expr\n";
- last if $signal;
- }
- }
- }
-}
+ # This is a restart point for commands that didn't arrive
+ # via direct user input. It allows us to 'redo PIPE' to
+ # re-execute command processing without reading a new command.
+ PIPE: {
+ $cmd =~ s/^\s+//s; # trim annoying leading whitespace
+ $cmd =~ s/\s+$//s; # trim annoying trailing whitespace
+ ($i) = split (/\s+/, $cmd);
-sub cmd_M {
- &list_modules();
-}
+=head3 COMMAND ALIASES
+
+The debugger can create aliases for commands (these are stored in the
+C<%alias> hash). Before a command is executed, the command loop looks it up
+in the alias hash and substitutes the contents of the alias for the command,
+completely replacing it.
+
+=cut
+
+ # See if there's an alias for the command, and set it up if so.
+ if ($alias{$i}) {
+ # Squelch signal handling; we want to keep control here
+ # if something goes loco during the alias eval.
+ local $SIG{__DIE__};
+ local $SIG{__WARN__};
+
+ # This is a command, so we eval it in the DEBUGGER's
+ # scope! Otherwise, we can't see the special debugger
+ # variables, or get to the debugger's subs. (Well, we
+ # _could_, but why make it even more complicated?)
+ eval "\$cmd =~ $alias{$i}";
+ if ($@) {
+ local $\ = '';
+ print $OUT "Couldn't evaluate `$i' alias: $@";
+ next CMD;
+ }
+ } ## end if ($alias{$i})
+
+=head3 MAIN-LINE COMMANDS
+
+All of these commands work up to and after the program being debugged has
+terminated.
+
+=head4 C<q> - quit
+
+Quit the debugger. This entails setting the C<$fall_off_end> flag, so we don't
+try to execute further, cleaning any restart-related stuff out of the
+environment, and executing with the last value of C<$?>.
+
+=cut
+
+ $cmd =~ /^q$/ && do {
+ $fall_off_end = 1;
+ clean_ENV();
+ exit $?;
+ };
+=head4 C<t> - trace
+
+Turn tracing on or off. Inverts the appropriate bit in C<$trace> (q.v.).
+
+=cut
+
+ $cmd =~ /^t$/ && do {
+ $trace ^= 1;
+ local $\ = '';
+ print $OUT "Trace = " . (($trace & 1) ? "on" : "off") .
+ "\n";
+ next CMD;
+ };
+
+=head4 C<S> - list subroutines matching/not matching a pattern
+
+Walks through C<%sub>, checking to see whether or not to print the name.
+
+=cut
+
+ $cmd =~ /^S(\s+(!)?(.+))?$/ && do {
+
+ $Srev = defined $2; # Reverse scan?
+ $Spatt = $3; # The pattern (if any) to use.
+ $Snocheck = !defined $1; # No args - print all subs.
+
+ # Need to make these sane here.
+ local $\ = '';
+ local $, = '';
+
+ # Search through the debugger's magical hash of subs.
+ # If $nocheck is true, just print the sub name.
+ # Otherwise, check it against the pattern. We then use
+ # the XOR trick to reverse the condition as required.
+ foreach $subname (sort(keys %sub)) {
+ if ($Snocheck or $Srev ^ ($subname =~ /$Spatt/)) {
+ print $OUT $subname, "\n";
+ }
+ }
+ next CMD;
+ };
+
+=head4 C<X> - list variables in current package
+
+Since the C<V> command actually processes this, just change this to the
+appropriate C<V> command and fall through.
+
+=cut
+
+ $cmd =~ s/^X\b/V $package/;
+
+=head4 C<V> - list variables
+
+Uses C<dumpvar.pl> to dump out the current values for selected variables.
+
+=cut
+
+ # Bare V commands get the currently-being-debugged package
+ # added.
+ $cmd =~ /^V$/ && do {
+ $cmd = "V $package";
+ };
+
+
+ # V - show variables in package.
+ $cmd =~ /^V\b\s*(\S+)\s*(.*)/ && do {
+ # Save the currently selected filehandle and
+ # force output to debugger's filehandle (dumpvar
+ # just does "print" for output).
+ local ($savout) = select($OUT);
+
+ # Grab package name and variables to dump.
+ $packname = $1;
+ @vars = split (' ', $2);
+
+ # If main::dumpvar isn't here, get it.
+ do 'dumpvar.pl' unless defined &main::dumpvar;
+ if (defined &main::dumpvar) {
+ # We got it. Turn off subroutine entry/exit messages
+ # for the moment. XXX Why do this to doret?
+ local $frame = 0;
+ local $doret = -2;
+
+ # must detect sigpipe failures - not catching
+ # then will cause the debugger to die.
+ eval {
+ &main::dumpvar(
+ $packname,
+ defined $option{dumpDepth}
+ ? $option{dumpDepth}
+ : -1, # assume -1 unless specified
+ @vars
+ );
+ };
+
+ # The die doesn't need to include the $@, because
+ # it will automatically get propagated for us.
+ if ($@) {
+ die unless $@ =~ /dumpvar print failed/;
+ }
+ } ## end if (defined &main::dumpvar)
+ else {
+ # Couldn't load dumpvar.
+ print $OUT "dumpvar.pl not available.\n";
+ }
+ # Restore the output filehandle, and go round again.
+ select($savout);
+ next CMD;
+ };
+
+=head4 C<x> - evaluate and print an expression
+
+Hands the expression off to C<DB::eval>, setting it up to print the value
+via C<dumpvar.pl> instead of just printing it directly.
+
+=cut
+
+ $cmd =~ s/^x\b/ / && do { # Remainder gets done by DB::eval()
+ $onetimeDump = 'dump'; # main::dumpvar shows the output
+
+ # handle special "x 3 blah" syntax XXX propagate
+ # doc back to special variables.
+ if ($cmd =~ s/^\s*(\d+)(?=\s)/ /) {
+ $onetimedumpDepth = $1;
+ }
+ };
+
+=head4 C<m> - print methods
+
+Just uses C<DB::methods> to determine what methods are available.
+
+=cut
+
+ $cmd =~ s/^m\s+([\w:]+)\s*$/ / && do {
+ methods($1);
+ next CMD;
+ };
+
+ # m expr - set up DB::eval to do the work
+ $cmd =~ s/^m\b/ / && do { # Rest gets done by DB::eval()
+ $onetimeDump = 'methods'; # method output gets used there
+ };
+
+=head4 C<f> - switch files
+
+=cut
+
+ $cmd =~ /^f\b\s*(.*)/ && do {
+ $file = $1;
+ $file =~ s/\s+$//;
+
+ # help for no arguments (old-style was return from sub).
+ if (!$file) {
+ print $OUT
+ "The old f command is now the r command.\n"; # hint
+ print $OUT "The new f command switches filenames.\n";
+ next CMD;
+ } ## end if (!$file)
+
+ # if not in magic file list, try a close match.
+ if (!defined $main::{ '_<' . $file }) {
+ if (($try) = grep(m#^_<.*$file#, keys %main::)) {
+ {
+ $try = substr($try, 2);
+ print $OUT
+ "Choosing $try matching `$file':\n";
+ $file = $try;
+ }
+ } ## end if (($try) = grep(m#^_<.*$file#...
+ } ## end if (!defined $main::{ ...
+
+ # If not successfully switched now, we failed.
+ if (!defined $main::{ '_<' . $file }) {
+ print $OUT "No file matching `$file' is loaded.\n";
+ next CMD;
+ }
+
+ # We switched, so switch the debugger internals around.
+ elsif ($file ne $filename) {
+ *dbline = $main::{ '_<' . $file };
+ $max = $#dbline;
+ $filename = $file;
+ $start = 1;
+ $cmd = "l";
+ } ## end elsif ($file ne $filename)
+
+ # We didn't switch; say we didn't.
+ else {
+ print $OUT "Already in $file.\n";
+ next CMD;
+ }
+ };
+
+=head4 C<.> - return to last-executed line.
+
+We set C<$incr> to -1 to indicate that the debugger shouldn't move ahead,
+and then we look up the line in the magical C<%dbline> hash.
+
+=cut
+
+ # . command.
+ $cmd =~ /^\.$/ && do {
+ $incr = -1; # stay at current line
+
+ # Reset everything to the old location.
+ $start = $line;
+ $filename = $filename_ini;
+ *dbline = $main::{ '_<' . $filename };
+ $max = $#dbline;
+
+ # Now where are we?
+ print_lineinfo($position);
+ next CMD;
+ };
+
+=head4 C<-> - back one window
+
+We change C<$start> to be one window back; if we go back past the first line,
+we set it to be the first line. We ser C<$incr> to put us back at the
+currently-executing line, and then put a C<l $start +> (list one window from
+C<$start>) in C<$cmd> to be executed later.
+
+=cut
+
+ # - - back a window.
+ $cmd =~ /^-$/ && do {
+ # back up by a window; go to 1 if back too far.
+ $start -= $incr + $window + 1;
+ $start = 1 if $start <= 0;
+ $incr = $window - 1;
+
+ # Generate and execute a "l +" command (handled below).
+ $cmd = 'l ' . ($start) . '+';
+ };
+
+=head3 PRE-580 COMMANDS VS. NEW COMMANDS: C<a, A, b, B, h, l, L, M, o, O, P, v,
+w, W, E<lt>, E<lt>E<lt>, {, {{>
+
+In Perl 5.8.0, a realignment of the commands was done to fix up a number of
+problems, most notably that the default case of several commands destroying
+the user's work in setting watchpoints, actions, etc. We wanted, however, to
+retain the old commands for those who were used to using them or who preferred
+them. At this point, we check for the new commands and call C<cmd_wrapper> to
+deal with them instead of processing them in-line.
+
+=cut
+
+ # All of these commands were remapped in perl 5.8.0;
+ # we send them off to the secondary dispatcher (see below).
+ $cmd =~ /^([aAbBhlLMoOvwW]\b|[<>\{]{1,2})\s*(.*)/so && do {
+ &cmd_wrapper($1, $2, $line);
+ next CMD;
+ };
+
+=head4 C<y> - List lexicals in higher scope
+
+Uses C<PadWalker> to find the lexicals supplied as arguments in a scope
+above the current one and then displays then using C<dumpvar.pl>.
+
+=cut
+
+ $cmd =~ /^y(?:\s+(\d*)\s*(.*))?$/ && do {
+
+ # See if we've got the necessary support.
+ eval { require PadWalker; PadWalker->VERSION(0.08) }
+ or &warn(
+ $@ =~ /locate/
+ ? "PadWalker module not found - please install\n"
+ : $@
+ )
+ and next CMD;
+
+ # Load up dumpvar if we don't have it. If we can, that is.
+ do 'dumpvar.pl' unless defined &main::dumpvar;
+ defined &main::dumpvar
+ or print $OUT "dumpvar.pl not available.\n"
+ and next CMD;
+
+ # Got all the modules we need. Find them and print them.
+ my @vars = split (' ', $2 || '');
+
+ # Find the pad.
+ my $h = eval { PadWalker::peek_my(($1 || 0) + 1) };
+
+ # Oops. Can't find it.
+ $@ and $@ =~ s/ at .*//, &warn($@), next CMD;
+
+ # Show the desired vars with dumplex().
+ my $savout = select($OUT);
+
+ # Have dumplex dump the lexicals.
+ dumpvar::dumplex(
+ $_,
+ $h->{$_},
+ defined $option{dumpDepth} ? $option{dumpDepth} : -1,
+ @vars
+ ) for sort keys %$h;
+ select($savout);
+ next CMD;
+ };
+
+=head3 COMMANDS NOT WORKING AFTER PROGRAM ENDS
+
+All of the commands below this point don't work after the program being
+debugged has ended. All of them check to see if the program has ended; this
+allows the commands to be relocated without worrying about a 'line of
+demarcation' above which commands can be entered anytime, and below which
+they can't.
+
+=head4 C<n> - single step, but don't trace down into subs
+
+Done by setting C<$single> to 2, which forces subs to execute straight through
+when entered (see X<DB::sub>). We also save the C<n> command in C<$laststep>,
+so a null command knows what to re-execute.
+
+=cut
+
+ # n - next
+ $cmd =~ /^n$/ && do {
+ end_report(), next CMD if $finished and $level <= 1;
+ # Single step, but don't enter subs.
+ $single = 2;
+ # Save for empty command (repeat last).
+ $laststep = $cmd;
+ last CMD;
+ };
+
+=head4 C<s> - single-step, entering subs
+
+Sets C<$single> to 1, which causes X<DB::sub> to continue tracing inside
+subs. Also saves C<s> as C<$lastcmd>.
+
+=cut
+
+ # s - single step.
+ $cmd =~ /^s$/ && do {
+ # Get out and restart the command loop if program
+ # has finished.
+ end_report(), next CMD if $finished and $level <= 1;
+ # Single step should enter subs.
+ $single = 1;
+ # Save for empty command (repeat last).
+ $laststep = $cmd;
+ last CMD;
+ };
+
+=head4 C<c> - run continuously, setting an optional breakpoint
+
+Most of the code for this command is taken up with locating the optional
+breakpoint, which is either a subroutine name or a line number. We set
+the appropriate one-time-break in C<@dbline> and then turn off single-stepping
+in this and all call levels above this one.
+
+=cut
+
+ # c - start continuous execution.
+ $cmd =~ /^c\b\s*([\w:]*)\s*$/ && do {
+ # Hey, show's over. The debugged program finished
+ # executing already.
+ end_report(), next CMD if $finished and $level <= 1;
+
+ # Capture the place to put a one-time break.
+ $subname = $i = $1;
+
+ # Probably not needed, since we finish an interactive
+ # sub-session anyway...
+ # local $filename = $filename;
+ # local *dbline = *dbline; # XXX Would this work?!
+ #
+ # The above question wonders if localizing the alias
+ # to the magic array works or not. Since it's commented
+ # out, we'll just leave that to speculation for now.
+
+ # If the "subname" isn't all digits, we'll assume it
+ # is a subroutine name, and try to find it.
+ if ($subname =~ /\D/) { # subroutine name
+ # Qualify it to the current package unless it's
+ # already qualified.
+ $subname = $package . "::" . $subname
+ unless $subname =~ /::/;
+ # find_sub will return "file:line_number" corresponding
+ # to where the subroutine is defined; we call find_sub,
+ # break up the return value, and assign it in one
+ # operation.
+ ($file, $i) = (find_sub($subname) =~ /^(.*):(.*)$/);
+
+ # Force the line number to be numeric.
+ $i += 0;
+
+ # If we got a line number, we found the sub.
+ if ($i) {
+ # Switch all the debugger's internals around so
+ # we're actually working with that file.
+ $filename = $file;
+ *dbline = $main::{ '_<' . $filename };
+ # Mark that there's a breakpoint in this file.
+ $had_breakpoints{$filename} |= 1;
+ # Scan forward to the first executable line
+ # after the 'sub whatever' line.
+ $max = $#dbline;
+ ++$i while $dbline[$i] == 0 && $i < $max;
+ } ## end if ($i)
+
+ # We didn't find a sub by that name.
+ else {
+ print $OUT "Subroutine $subname not found.\n";
+ next CMD;
+ }
+ } ## end if ($subname =~ /\D/)
+
+ # At this point, either the subname was all digits (an
+ # absolute line-break request) or we've scanned through
+ # the code following the definition of the sub, looking
+ # for an executable, which we may or may not have found.
+ #
+ # If $i (which we set $subname from) is non-zero, we
+ # got a request to break at some line somewhere. On
+ # one hand, if there wasn't any real subroutine name
+ # involved, this will be a request to break in the current
+ # file at the specified line, so we have to check to make
+ # sure that the line specified really is breakable.
+ #
+ # On the other hand, if there was a subname supplied, the
+ # preceeding block has moved us to the proper file and
+ # location within that file, and then scanned forward
+ # looking for the next executable line. We have to make
+ # sure that one was found.
+ #
+ # On the gripping hand, we can't do anything unless the
+ # current value of $i points to a valid breakable line.
+ # Check that.
+ if ($i) {
+ # Breakable?
+ if ($dbline[$i] == 0) {
+ print $OUT "Line $i not breakable.\n";
+ next CMD;
+ }
+ # Yes. Set up the one-time-break sigil.
+ $dbline{$i} =~
+ s/($|\0)/;9$1/; # add one-time-only b.p.
+ } ## end if ($i)
+
+ # Turn off stack tracing from here up.
+ for ($i = 0 ; $i <= $stack_depth ;) {
+ $stack[$i++] &= ~1;
+ }
+ last CMD;
+ };
+
+=head4 C<r> - return from a subroutine
+
+For C<r> to work properly, the debugger has to stop execution again
+immediately after the return is executed. This is done by forcing
+single-stepping to be on in the call level above the current one. If
+we are printing return values when a C<r> is executed, set C<$doret>
+appropriately, and force us out of the command loop.
+
+=cut
+
+ # r - return from the current subroutine.
+ $cmd =~ /^r$/ && do {
+ # Can't do anythign if the program's over.
+ end_report(), next CMD if $finished and $level <= 1;
+ # Turn on stack trace.
+ $stack[$stack_depth] |= 1;
+ # XXX weird stack fram management?
+ $doret = $option{PrintRet} ? $stack_depth - 1 : -2;
+ last CMD;
+ };
+
+=head4 C<R> - restart
+
+Restarting the debugger is a complex operation that occurs in several phases.
+First, we try to reconstruct the command line that was used to invoke Perl
+and the debugger.
+
+=cut
+
+ # R - restart execution.
+ $cmd =~ /^R$/ && do {
+ # I may not be able to resurrect you, but here goes ...
+ print $OUT
+"Warning: some settings and command-line options may be lost!\n";
+ my (@script, @flags, $cl);
+
+ # If warn was on before, turn it on again.
+ push @flags, '-w' if $ini_warn;
+
+ # Rebuild the -I flags that were on the initial
+ # command line.
+ for (@ini_INC) {
+ push @flags, '-I', $_;
+ }
+
+ # Turn on taint if it was on before.
+ push @flags, '-T' if ${^TAINT};
+
+ # Arrange for setting the old INC:
+ # Save the current @init_INC in the environment.
+ set_list("PERLDB_INC", @ini_INC);
+
+ # If this was a perl one-liner, go to the "file"
+ # corresponding to the one-liner read all the lines
+ # out of it (except for the first one, which is going
+ # to be added back on again when 'perl -d' runs: that's
+ # the 'require perl5db.pl;' line), and add them back on
+ # to the command line to be executed.
+ if ($0 eq '-e') {
+ for (1 .. $#{'::_<-e'}) { # The first line is PERL5DB
+ chomp($cl = ${'::_<-e'}[$_]);
+ push @script, '-e', $cl;
+ }
+ } ## end if ($0 eq '-e')
+
+ # Otherwise we just reuse the original name we had
+ # before.
+ else {
+ @script = $0;
+ }
+
+=pod
+
+After the command line has been reconstructed, the next step is to save
+the debugger's status in environment variables. The C<DB::set_list> routine
+is used to save aggregate variables (both hashes and arrays); scalars are
+just popped into environment variables directly.
+
+=cut
+
+ # If the terminal supported history, grab it and
+ # save that in the environment.
+ set_list("PERLDB_HIST",
+ $term->Features->{getHistory}
+ ? $term->GetHistory
+ : @hist);
+ # Find all the files that were visited during this
+ # session (i.e., the debugger had magic hashes
+ # corresponding to them) and stick them in the environment.
+ my @had_breakpoints = keys %had_breakpoints;
+ set_list("PERLDB_VISITED", @had_breakpoints);
+
+ # Save the debugger options we chose.
+ set_list("PERLDB_OPT", %option);
+
+ # Save the break-on-loads.
+ set_list("PERLDB_ON_LOAD", %break_on_load);
+
+=pod
+
+The most complex part of this is the saving of all of the breakpoints. They
+can live in an awful lot of places, and we have to go through all of them,
+find the breakpoints, and then save them in the appropriate environment
+variable via C<DB::set_list>.
+
+=cut
+
+ # Go through all the breakpoints and make sure they're
+ # still valid.
+ my @hard;
+ for (0 .. $#had_breakpoints) {
+ # We were in this file.
+ my $file = $had_breakpoints[$_];
+
+ # Grab that file's magic line hash.
+ *dbline = $main::{ '_<' . $file };
+
+ # Skip out if it doesn't exist, or if the breakpoint
+ # is in a postponed file (we'll do postponed ones
+ # later).
+ next unless %dbline or $postponed_file{$file};
+
+ # In an eval. This is a little harder, so we'll
+ # do more processing on that below.
+ (push @hard, $file), next
+ if $file =~ /^\(\w*eval/;
+ # XXX I have no idea what this is doing. Yet.
+ my @add;
+ @add = %{ $postponed_file{$file} }
+ if $postponed_file{$file};
+
+ # Save the list of all the breakpoints for this file.
+ set_list("PERLDB_FILE_$_", %dbline, @add);
+ } ## end for (0 .. $#had_breakpoints)
+
+ # The breakpoint was inside an eval. This is a little
+ # more difficult. XXX and I don't understand it.
+ for (@hard) {
+ # Get over to the eval in question.
+ *dbline = $main::{ '_<' . $_ };
+ my ($quoted, $sub, %subs, $line) = quotemeta $_;
+ for $sub (keys %sub) {
+ next unless $sub{$sub} =~ /^$quoted:(\d+)-(\d+)$/;
+ $subs{$sub} = [$1, $2];
+ }
+ unless (%subs) {
+ print $OUT
+ "No subroutines in $_, ignoring breakpoints.\n";
+ next;
+ }
+ LINES: for $line (keys %dbline) {
+
+ # One breakpoint per sub only:
+ my ($offset, $sub, $found);
+ SUBS: for $sub (keys %subs) {
+ if (
+ $subs{$sub}->[1] >=
+ $line # Not after the subroutine
+ and (
+ not defined $offset # Not caught
+ or $offset < 0
+ )
+ )
+ { # or badly caught
+ $found = $sub;
+ $offset = $line - $subs{$sub}->[0];
+ $offset = "+$offset", last SUBS
+ if $offset >= 0;
+ } ## end if ($subs{$sub}->[1] >=...
+ } ## end for $sub (keys %subs)
+ if (defined $offset) {
+ $postponed{$found} =
+ "break $offset if $dbline{$line}";
+ }
+ else {
+ print $OUT
+"Breakpoint in $_:$line ignored: after all the subroutines.\n";
+ }
+ } ## end for $line (keys %dbline)
+ } ## end for (@hard)
+
+ # Save the other things that don't need to be
+ # processed.
+ set_list("PERLDB_POSTPONE", %postponed);
+ set_list("PERLDB_PRETYPE", @$pretype);
+ set_list("PERLDB_PRE", @$pre);
+ set_list("PERLDB_POST", @$post);
+ set_list("PERLDB_TYPEAHEAD", @typeahead);
+
+ # We are oficially restarting.
+ $ENV{PERLDB_RESTART} = 1;
+
+ # We are junking all child debuggers.
+ delete $ENV{PERLDB_PIDS}; # Restore ini state
+
+ # Set this back to the initial pid.
+ $ENV{PERLDB_PIDS} = $ini_pids if defined $ini_pids;
+
+=pod
+
+After all the debugger status has been saved, we take the command we built
+up and then C<exec()> it. The debugger will spot the C<PERLDB_RESTART>
+environment variable and realize it needs to reload its state from the
+environment.
+
+=cut
+
+ # And run Perl again. Add the "-d" flag, all the
+ # flags we built up, the script (whether a one-liner
+ # or a file), add on the -emacs flag for a slave editor,
+ # and then the old arguments. We use exec() to keep the
+ # PID stable (and that way $ini_pids is still valid).
+ exec($^X, '-d', @flags, @script,
+ ($slave_editor ? '-emacs' : ()), @ARGS) ||
+ print $OUT "exec failed: $!\n";
+ last CMD;
+ };
+
+=head4 C<T> - stack trace
+
+Just calls C<DB::print_trace>.
+
+=cut
+
+ $cmd =~ /^T$/ && do {
+ print_trace($OUT, 1); # skip DB
+ next CMD;
+ };
+
+=head4 C<w> - List window around current line.
+
+Just calls C<DB::cmd_w>.
+
+=cut
+
+ $cmd =~ /^w\b\s*(.*)/s && do { &cmd_w('w', $1); next CMD; };
+
+=head4 C<W> - watch-expression processing.
+
+Just calls C<DB::cmd_W>.
+
+=cut
+
+ $cmd =~ /^W\b\s*(.*)/s && do { &cmd_W('W', $1); next CMD; };
+
+=head4 C</> - search forward for a string in the source
+
+We take the argument and treat it as a pattern. If it turns out to be a
+bad one, we return the error we got from trying to C<eval> it and exit.
+If not, we create some code to do the search and C<eval> it so it can't
+mess us up.
+
+=cut
+
+ $cmd =~ /^\/(.*)$/ && do {
+
+ # The pattern as a string.
+ $inpat = $1;
+
+ # Remove the final slash.
+ $inpat =~ s:([^\\])/$:$1:;
+
+ # If the pattern isn't null ...
+ if ($inpat ne "") {
+
+ # Turn of warn and die procesing for a bit.
+ local $SIG{__DIE__};
+ local $SIG{__WARN__};
+
+ # Create the pattern.
+ eval '$inpat =~ m' . "\a$inpat\a";
+ if ($@ ne "") {
+ # Oops. Bad pattern. No biscuit.
+ # Print the eval error and go back for more
+ # commands.
+ print $OUT "$@";
+ next CMD;
+ }
+ $pat = $inpat;
+ } ## end if ($inpat ne "")
+
+ # Set up to stop on wrap-around.
+ $end = $start;
+
+ # Don't move off the current line.
+ $incr = -1;
+
+ # Done in eval so nothing breaks if the pattern
+ # does something weird.
+ eval '
+ for (;;) {
+ # Move ahead one line.
+ ++$start;
+
+ # Wrap if we pass the last line.
+ $start = 1 if ($start > $max);
+
+ # Stop if we have gotten back to this line again,
+ last if ($start == $end);
+
+ # A hit! (Note, though, that we are doing
+ # case-insensitive matching. Maybe a qr//
+ # expression would be better, so the user could
+ # do case-sensitive matching if desired.
+ if ($dbline[$start] =~ m' . "\a$pat\a" . 'i) {
+ if ($slave_editor) {
+ # Handle proper escaping in the slave.
+ print $OUT "\032\032$filename:$start:0\n";
+ }
+ else {
+ # Just print the line normally.
+ print $OUT "$start:\t",$dbline[$start],"\n";
+ }
+ # And quit since we found something.
+ last;
+ }
+ } ';
+ # If we wrapped, there never was a match.
+ print $OUT "/$pat/: not found\n" if ($start == $end);
+ next CMD;
+ };
+
+=head4 C<?> - search backward for a string in the source
+
+Same as for C</>, except the loop runs backwards.
+
+=cut
+
+ # ? - backward pattern search.
+ $cmd =~ /^\?(.*)$/ && do {
+
+ # Get the pattern, remove trailing question mark.
+ $inpat = $1;
+ $inpat =~ s:([^\\])\?$:$1:;
+
+ # If we've got one ...
+ if ($inpat ne "") {
+
+ # Turn off die & warn handlers.
+ local $SIG{__DIE__};
+ local $SIG{__WARN__};
+ eval '$inpat =~ m' . "\a$inpat\a";
+
+ if ($@ ne "") {
+ # Ouch. Not good. Print the error.
+ print $OUT $@;
+ next CMD;
+ }
+ $pat = $inpat;
+ } ## end if ($inpat ne "")
+
+ # Where we are now is where to stop after wraparound.
+ $end = $start;
+
+ # Don't move away from this line.
+ $incr = -1;
+
+ # Search inside the eval to prevent pattern badness
+ # from killing us.
+ eval '
+ for (;;) {
+ # Back up a line.
+ --$start;
+
+ # Wrap if we pass the first line.
+ $start = $max if ($start <= 0);
+
+ # Quit if we get back where we started,
+ last if ($start == $end);
+
+ # Match?
+ if ($dbline[$start] =~ m' . "\a$pat\a" . 'i) {
+ if ($slave_editor) {
+ # Yep, follow slave editor requirements.
+ print $OUT "\032\032$filename:$start:0\n";
+ }
+ else {
+ # Yep, just print normally.
+ print $OUT "$start:\t",$dbline[$start],"\n";
+ }
+
+ # Found, so done.
+ last;
+ }
+ } ';
+
+ # Say we failed if the loop never found anything,
+ print $OUT "?$pat?: not found\n" if ($start == $end);
+ next CMD;
+ };
+
+=head4 C<$rc> - Recall command
+
+Manages the commands in C<@hist> (which is created if C<Term::ReadLine> reports
+that the terminal supports history). It find the the command required, puts it
+into C<$cmd>, and redoes the loop to execute it.
+
+=cut
+
+ # $rc - recall command.
+ $cmd =~ /^$rc+\s*(-)?(\d+)?$/ && do {
+
+ # No arguments, take one thing off history.
+ pop (@hist) if length($cmd) > 1;
+
+ # Relative (- found)?
+ # Y - index back from most recent (by 1 if bare minus)
+ # N - go to that particular command slot or the last
+ # thing if nothing following.
+ $i = $1 ? ($#hist - ($2 || 1)) : ($2 || $#hist);
+
+ # Pick out the command desired.
+ $cmd = $hist[$i];
+
+ # Print the command to be executed and restart the loop
+ # with that command in the buffer.
+ print $OUT $cmd, "\n";
+ redo CMD;
+ };
+
+=head4 C<$sh$sh> - C<system()> command
+
+Calls the C<DB::system()> to handle the command. This keeps the C<STDIN> and
+C<STDOUT> from getting messed up.
+
+=cut
+
+ # $sh$sh - run a shell command (if it's all ASCII).
+ # Can't run shell commands with Unicode in the debugger, hmm.
+ $cmd =~ /^$sh$sh\s*([\x00-\xff]*)/ && do {
+ # System it.
+ &system($1);
+ next CMD;
+ };
+
+=head4 C<$rc I<pattern> $rc> - Search command history
+
+Another command to manipulate C<@hist>: this one searches it with a pattern.
+If a command is found, it is placed in C<$cmd> and executed via <redo>.
+
+=cut
+
+ # $rc pattern $rc - find a command in the history.
+ $cmd =~ /^$rc([^$rc].*)$/ && do {
+ # Create the pattern to use.
+ $pat = "^$1";
+
+ # Toss off last entry if length is >1 (and it always is).
+ pop (@hist) if length($cmd) > 1;
+
+ # Look backward through the history.
+ for ($i = $#hist ; $i ; --$i) {
+ # Stop if we find it.
+ last if $hist[$i] =~ /$pat/;
+ }
+
+ if (!$i) {
+ # Never found it.
+ print $OUT "No such command!\n\n";
+ next CMD;
+ }
+
+ # Found it. Put it in the buffer, print it, and process it.
+ $cmd = $hist[$i];
+ print $OUT $cmd, "\n";
+ redo CMD;
+ };
+
+=head4 C<$sh> - Invoke a shell
+
+Uses C<DB::system> to invoke a shell.
+
+=cut
+
+ # $sh - start a shell.
+ $cmd =~ /^$sh$/ && do {
+ # Run the user's shell. If none defined, run Bourne.
+ # We resume execution when the shell terminates.
+ &system($ENV{SHELL} || "/bin/sh");
+ next CMD;
+ };
+
+=head4 C<$sh I<command>> - Force execution of a command in a shell
+
+Like the above, but the command is passed to the shell. Again, we use
+C<DB::system> to avoid problems with C<STDIN> and C<STDOUT>.
+
+=cut
+
+ # $sh command - start a shell and run a command in it.
+ $cmd =~ /^$sh\s*([\x00-\xff]*)/ && do {
+ # XXX: using csh or tcsh destroys sigint retvals!
+ #&system($1); # use this instead
+
+ # use the user's shell, or Bourne if none defined.
+ &system($ENV{SHELL} || "/bin/sh", "-c", $1);
+ next CMD;
+ };
+
+=head4 C<H> - display commands in history
+
+Prints the contents of C<@hist> (if any).
+
+=cut
+
+ $cmd =~ /^H\b\s*(-(\d+))?/ && do {
+ # Anything other than negative numbers is ignored by
+ # the (incorrect) pattern, so this test does nothing.
+ $end = $2 ? ($#hist - $2) : 0;
+
+ # Set to the minimum if less than zero.
+ $hist = 0 if $hist < 0;
+
+ # Start at the end of the array.
+ # Stay in while we're still above the ending value.
+ # Tick back by one each time around the loop.
+ for ($i = $#hist ; $i > $end ; $i--) {
+
+ # Print the command unless it has no arguments.
+ print $OUT "$i: ", $hist[$i], "\n"
+ unless $hist[$i] =~ /^.?$/;
+ }
+ next CMD;
+ };
+
+=head4 C<man, doc, perldoc> - look up documentation
+
+Just calls C<runman()> to print the appropriate document.
+
+=cut
+
+ # man, perldoc, doc - show manual pages.
+ $cmd =~ /^(?:man|(?:perl)?doc)\b(?:\s+([^(]*))?$/ && do {
+ runman($1);
+ next CMD;
+ };
+
+=head4 C<p> - print
+
+Builds a C<print EXPR> expression in the C<$cmd>; this will get executed at
+the bottom of the loop.
+
+=cut
+
+ # p - print (no args): print $_.
+ $cmd =~ s/^p$/print {\$DB::OUT} \$_/;
+
+ # p - print the given expression.
+ $cmd =~ s/^p\b/print {\$DB::OUT} /;
+
+=head4 C<=> - define command alias
+
+Manipulates C<%alias> to add or list command aliases.
+
+=cut
+
+ # = - set up a command alias.
+ $cmd =~ s/^=\s*// && do {
+ my @keys;
+ if (length $cmd == 0) {
+ # No args, get current aliases.
+ @keys = sort keys %alias;
+ }
+ elsif (my ($k, $v) = ($cmd =~ /^(\S+)\s+(\S.*)/)) {
+ # Creating a new alias. $k is alias name, $v is
+ # alias value.
+
+ # can't use $_ or kill //g state
+ for my $x ($k, $v) {
+ # Escape "alarm" characters.
+ $x =~ s/\a/\\a/g
+ }
+
+ # Substitute key for value, using alarm chars
+ # as separators (which is why we escaped them in
+ # the command).
+ $alias{$k} = "s\a$k\a$v\a";
+
+ # Turn off standard warn and die behavior.
+ local $SIG{__DIE__};
+ local $SIG{__WARN__};
+
+ # Is it valid Perl?
+ unless (eval "sub { s\a$k\a$v\a }; 1") {
+ # Nope. Bad alias. Say so and get out.
+ print $OUT "Can't alias $k to $v: $@\n";
+ delete $alias{$k};
+ next CMD;
+ }
+ # We'll only list the new one.
+ @keys = ($k);
+ } ## end elsif (my ($k, $v) = ($cmd...
+
+ # The argument is the alias to list.
+ else {
+ @keys = ($cmd);
+ }
+
+ # List aliases.
+ for my $k (@keys) {
+ # Messy metaquoting: Trim the substiution code off.
+ # We use control-G as the delimiter because it's not
+ # likely to appear in the alias.
+ if ((my $v = $alias{$k}) =~ s\as\a$k\a(.*)\a$\a1\a) {
+ # Print the alias.
+ print $OUT "$k\t= $1\n";
+ }
+ elsif (defined $alias{$k}) {
+ # Couldn't trim it off; just print the alias code.
+ print $OUT "$k\t$alias{$k}\n";
+ }
+ else {
+ # No such, dude.
+ print "No alias for $k\n";
+ }
+ } ## end for my $k (@keys)
+ next CMD;
+ };
+
+=head4 C<source> - read commands from a file.
+
+Opens a lexical filehandle and stacks it on C<@cmdfhs>; C<DB::readline> will
+pick it up.
+
+=cut
+
+ # source - read commands from a file (or pipe!) and execute.
+ $cmd =~ /^source\s+(.*\S)/ && do {
+ if (open my $fh, $1) {
+ # Opened OK; stick it in the list of file handles.
+ push @cmdfhs, $fh;
+ }
+ else {
+ # Couldn't open it.
+ &warn("Can't execute `$1': $!\n");
+ }
+ next CMD;
+ };
+
+=head4 C<|, ||> - pipe output through the pager.
+
+FOR C<|>, we save C<OUT> (the debugger's output filehandle) and C<STDOUT>
+(the program's standard output). For C<||>, we only save C<OUT>. We open a
+pipe to the pager (restoring the output filehandles if this fails). If this
+is the C<|> command, we also set up a C<SIGPIPE> handler which will simply
+set C<$signal>, sending us back into the debugger.
+
+We then trim off the pipe symbols and C<redo> the command loop at the
+C<PIPE> label, causing us to evaluate the command in C<$cmd> without
+reading another.
+
+=cut
+
+ # || - run command in the pager, with output to DB::OUT.
+ $cmd =~ /^\|\|?\s*[^|]/ && do {
+ if ($pager =~ /^\|/) {
+ # Default pager is into a pipe. Redirect I/O.
+ open(SAVEOUT, ">&STDOUT") ||
+ &warn("Can't save STDOUT");
+ open(STDOUT, ">&OUT") ||
+ &warn("Can't redirect STDOUT");
+ } ## end if ($pager =~ /^\|/)
+ else {
+ # Not into a pipe. STDOUT is safe.
+ open(SAVEOUT, ">&OUT") || &warn("Can't save DB::OUT");
+ }
+
+ # Fix up environment to record we have less if so.
+ fix_less();
+
+ unless ($piped = open(OUT, $pager)) {
+ # Couldn't open pipe to pager.
+ &warn("Can't pipe output to `$pager'");
+ if ($pager =~ /^\|/) {
+ # Redirect I/O back again.
+ open(OUT, ">&STDOUT") # XXX: lost message
+ || &warn("Can't restore DB::OUT");
+ open(STDOUT, ">&SAVEOUT") ||
+ &warn("Can't restore STDOUT");
+ close(SAVEOUT);
+ } ## end if ($pager =~ /^\|/)
+ else {
+ # Redirect I/O. STDOUT already safe.
+ open(OUT, ">&STDOUT") # XXX: lost message
+ || &warn("Can't restore DB::OUT");
+ }
+ next CMD;
+ } ## end unless ($piped = open(OUT,...
+
+ # Set up broken-pipe handler if necessary.
+ $SIG{PIPE} = \&DB::catch
+ if $pager =~ /^\|/ &&
+ ("" eq $SIG{PIPE} || "DEFAULT" eq $SIG{PIPE});
+
+ # Save current filehandle, unbuffer out, and put it back.
+ $selected = select(OUT);
+ $| = 1;
+
+ # Don't put it back if pager was a pipe.
+ select($selected), $selected = "" unless $cmd =~ /^\|\|/;
+
+ # Trim off the pipe symbols and run the command now.
+ $cmd =~ s/^\|+\s*//;
+ redo PIPE;
+ };
+
+
+=head3 END OF COMMAND PARSING
+
+Anything left in C<$cmd> at this point is a Perl expression that we want to
+evaluate. We'll always evaluate in the user's context, and fully qualify
+any variables we might want to address in the C<DB> package.
+
+=cut
+
+ # t - turn trace on.
+ $cmd =~ s/^t\s/\$DB::trace |= 1;\n/;
+
+ # s - single-step. Remember the last command was 's'.
+ $cmd =~ s/^s\s/\$DB::single = 1;\n/ && do { $laststep = 's' };
+
+ # n - single-step, but not into subs. Remember last command
+ # was 'n'.
+ $cmd =~ s/^n\s/\$DB::single = 2;\n/ && do { $laststep = 'n' };
+
+ } # PIPE:
+
+ # Make sure the flag that says "the debugger's running" is
+ # still on, to make sure we get control again.
+ $evalarg = "\$^D = \$^D | \$DB::db_stop;\n$cmd";
+
+ # Run *our* eval that executes in the caller's context.
+ &eval;
+
+ # Turn off the one-time-dump stuff now.
+ if ($onetimeDump) {
+ $onetimeDump = undef;
+ $onetimedumpDepth = undef;
+ }
+ elsif ($term_pid == $$) {
+ # XXX If this is the master pid, print a newline.
+ print $OUT "\n";
+ }
+ } ## end while (($term || &setterm...
+
+=head3 POST-COMMAND PROCESSING
+
+After each command, we check to see if the command output was piped anywhere.
+If so, we go through the necessary code to unhook the pipe and go back to
+our standard filehandles for input and output.
+
+=cut
+
+ continue { # CMD:
+
+ # At the end of every command:
+ if ($piped) {
+ # Unhook the pipe mechanism now.
+ if ($pager =~ /^\|/) {
+ # No error from the child.
+ $? = 0;
+
+ # we cannot warn here: the handle is missing --tchrist
+ close(OUT) || print SAVEOUT "\nCan't close DB::OUT\n";
+
+ # most of the $? crud was coping with broken cshisms
+ # $? is explicitly set to 0, so this never runs.
+ if ($?) {
+ print SAVEOUT "Pager `$pager' failed: ";
+ if ($? == -1) {
+ print SAVEOUT "shell returned -1\n";
+ }
+ elsif ($? >> 8) {
+ print SAVEOUT ($? & 127)
+ ? " (SIG#" . ($? & 127) . ")"
+ : "", ($? & 128) ? " -- core dumped" : "", "\n";
+ }
+ else {
+ print SAVEOUT "status ", ($? >> 8), "\n";
+ }
+ } ## end if ($?)
+
+ # Reopen filehandle for our output (if we can) and
+ # restore STDOUT (if we can).
+ open(OUT, ">&STDOUT") || &warn("Can't restore DB::OUT");
+ open(STDOUT, ">&SAVEOUT") ||
+ &warn("Can't restore STDOUT");
+
+ # Turn off pipe exception handler if necessary.
+ $SIG{PIPE} = "DEFAULT" if $SIG{PIPE} eq \&DB::catch;
+
+ # Will stop ignoring SIGPIPE if done like nohup(1)
+ # does SIGINT but Perl doesn't give us a choice.
+ } ## end if ($pager =~ /^\|/)
+ else {
+ # Non-piped "pager". Just restore STDOUT.
+ open(OUT, ">&SAVEOUT") || &warn("Can't restore DB::OUT");
+ }
+
+ # Close filehandle pager was using, restore the normal one
+ # if necessary,
+ close(SAVEOUT);
+ select($selected), $selected = "" unless $selected eq "";
+
+ # No pipes now.
+ $piped = "";
+ } ## end if ($piped)
+ } # CMD:
+
+=head3 COMMAND LOOP TERMINATION
+
+When commands have finished executing, we come here. If the user closed the
+input filehandle, we turn on C<$fall_off_end> to emulate a C<q> command. We
+evaluate any post-prompt items. We restore C<$@>, C<$!>, C<$^E>, C<$,>, C<$/>,
+C<$\>, and C<$^W>, and return a null list as expected by the Perl interpreter.
+The interpreter will then execute the next line and then return control to us
+again.
+
+=cut
+
+ # No more commands? Quit.
+ $fall_off_end = 1 unless defined $cmd; # Emulate `q' on EOF
+
+ # Evaluate post-prompt commands.
+ foreach $evalarg (@$post) {
+ &eval;
+ }
+ } # if ($single || $signal)
+
+ # Put the user's globals back where you found them.
+ ($@, $!, $^E, $,, $/, $\, $^W) = @saved;
+ ();
+} ## end sub DB
+
+# The following code may be executed now:
+# BEGIN {warn 4}
+
+=head2 sub
+
+C<sub> is called whenever a subroutine call happens in the program being
+debugged. The variable C<$DB::sub> contains the name of the subroutine
+being called.
+
+The core function of this subroutine is to actually call the sub in the proper
+context, capturing its output. This of course causes C<DB::DB> to get called
+again, repeating until the subroutine ends and returns control to C<DB::sub>
+again. Once control returns, C<DB::sub> figures out whether or not to dump the
+return value, and returns its captured copy of the return value as its own
+return value. The value then feeds back into the program being debugged as if
+C<DB::sub> hadn't been there at all.
+
+C<sub> does all the work of printing the subroutine entry and exit messages
+enabled by setting C<$frame>. It notes what sub the autoloader got called for,
+and also prints the return value if needed (for the C<r> command and if
+the 16 bit is set in C<$frame>).
+
+It also tracks the subroutine call depth by saving the current setting of
+C<$single> in the C<@stack> package global; if this exceeds the value in
+C<$deep>, C<sub> automatically turns on printing of the current depth by
+setting the 4 bit in C<$single>. In any case, it keeps the current setting
+of stop/don't stop on entry to subs set as it currently is set.
+
+=head3 C<caller()> support
+
+If C<caller()> is called from the package C<DB>, it provides some
+additional data, in the following order:
+
+=over 4
+
+=item * C<$package>
+
+The package name the sub was in
+
+=item * C<$filename>
+
+The filename it was defined in
+
+=item * C<$line>
+
+The line number it was defined on
+
+=item * C<$subroutine>
+
+The subroutine name; C<'(eval)'> if an C<eval>().
+
+=item * C<$hasargs>
+
+1 if it has arguments, 0 if not
+
+=item * C<$wantarray>
+
+1 if array context, 0 if scalar context
+
+=item * C<$evaltext>
+
+The C<eval>() text, if any (undefined for C<eval BLOCK>)
+
+=item * C<$is_require>
+
+frame was created by a C<use> or C<require> statement
+
+=item * C<$hints>
+
+pragma information; subject to change between versions
+
+=item * C<$bitmask>
+
+pragma information: subject to change between versions
+
+=item * C<@DB::args>
+
+arguments with which the subroutine was invoked
+
+=back
+
+=cut
+
+sub sub {
+
+ # Whether or not the autoloader was running, a scalar to put the
+ # sub's return value in (if needed), and an array to put the sub's
+ # return value in (if needed).
+ my ($al, $ret, @ret) = "";
+
+ # If the last ten characters are C'::AUTOLOAD', note we've traced
+ # into AUTOLOAD for $sub.
+ if (length($sub) > 10 && substr($sub, -10, 10) eq '::AUTOLOAD') {
+ $al = " for $$sub";
+ }
+
+ # We stack the stack pointer and then increment it to protect us
+ # from a situation that might unwind a whole bunch of call frames
+ # at once. Localizing the stack pointer means that it will automatically
+ # unwind the same amount when multiple stack frames are unwound.
+ local $stack_depth = $stack_depth + 1; # Protect from non-local exits
+
+ # Expand @stack.
+ $#stack = $stack_depth;
+
+ # Save current single-step setting.
+ $stack[-1] = $single;
+
+ # Turn off all flags except single-stepping.
+ $single &= 1;
+
+ # If we've gotten really deeply recursed, turn on the flag that will
+ # make us stop with the 'deep recursion' message.
+ $single |= 4 if $stack_depth == $deep;
+
+ # If frame messages are on ...
+ (
+ $frame & 4 # Extended frame entry message
+ ? (
+ print_lineinfo(' ' x ($stack_depth - 1), "in "),
+
+ # Why -1? But it works! :-(
+ # Because print_trace will call add 1 to it and then call
+ # dump_trace; this results in our skipping -1+1 = 0 stack frames
+ # in dump_trace.
+ print_trace($LINEINFO, -1, 1, 1, "$sub$al")
+ )
+ : print_lineinfo(' ' x ($stack_depth - 1), "entering $sub$al\n")
+ # standard frame entry message
+ )
+ if $frame;
+
+ # Determine the sub's return type,and capture approppriately.
+ if (wantarray) {
+ # Called in array context. call sub and capture output.
+ # DB::DB will recursively get control again if appropriate; we'll come
+ # back here when the sub is finished.
+ @ret = &$sub;
+
+ # Pop the single-step value back off the stack.
+ $single |= $stack[$stack_depth--];
+
+ # Check for exit trace messages...
+ (
+ $frame & 4 # Extended exit message
+ ? (
+ print_lineinfo(' ' x $stack_depth, "out "),
+ print_trace($LINEINFO, -1, 1, 1, "$sub$al")
+ )
+ : print_lineinfo(' ' x $stack_depth, "exited $sub$al\n")
+ # Standard exit message
+ )
+ if $frame & 2;
+
+ # Print the return info if we need to.
+ if ($doret eq $stack_depth or $frame & 16) {
+ # Turn off output record separator.
+ local $\ = '';
+ my $fh = ($doret eq $stack_depth ? $OUT : $LINEINFO);
+
+ # Indent if we're printing because of $frame tracing.
+ print $fh ' ' x $stack_depth if $frame & 16;
+
+ # Print the return value.
+ print $fh "list context return from $sub:\n";
+ dumpit($fh, \@ret);
+
+ # And don't print it again.
+ $doret = -2;
+ } ## end if ($doret eq $stack_depth...
+ # And we have to return the return value now.
+ @ret;
+
+ } ## end if (wantarray)
+
+ # Scalar context.
+ else {
+ if (defined wantarray) {
+ # Save the value if it's wanted at all.
+ $ret = &$sub;
+ }
+ else {
+ # Void return, explicitly.
+ &$sub;
+ undef $ret;
+ }
+
+ # Pop the single-step value off the stack.
+ $single |= $stack[$stack_depth--];
+
+ # If we're doing exit messages...
+ (
+ $frame & 4 # Extended messsages
+ ? (
+ print_lineinfo(' ' x $stack_depth, "out "),
+ print_trace($LINEINFO, -1, 1, 1, "$sub$al")
+ )
+ : print_lineinfo(' ' x $stack_depth, "exited $sub$al\n")
+ # Standard messages
+ )
+ if $frame & 2;
+
+ # If we are supposed to show the return value... same as before.
+ if ($doret eq $stack_depth or $frame & 16 and defined wantarray) {
+ local $\ = '';
+ my $fh = ($doret eq $stack_depth ? $OUT : $LINEINFO);
+ print $fh (' ' x $stack_depth) if $frame & 16;
+ print $fh (
+ defined wantarray
+ ? "scalar context return from $sub: "
+ : "void context return from $sub\n"
+ );
+ dumpit($fh, $ret) if defined wantarray;
+ $doret = -2;
+ } ## end if ($doret eq $stack_depth...
+
+ # Return the appropriate scalar value.
+ $ret;
+ } ## end else [ if (wantarray)
+} ## end sub sub
+
+=head1 EXTENDED COMMAND HANDLING AND THE COMMAND API
+
+In Perl 5.8.0, there was a major realignment of the commands and what they did,
+Most of the changes were to systematize the command structure and to eliminate
+commands that threw away user input without checking.
+
+The following sections describe the code added to make it easy to support
+multiple command sets with conflicting command names. This section is a start
+at unifying all command processing to make it simpler to develop commands.
+
+Note that all the cmd_[a-zA-Z] subroutines require the command name, a line
+number, and C<$dbline> (the current line) as arguments.
+
+Support functions in this section which have multiple modes of failure C<die>
+on error; the rest simply return a false value.
+
+The user-interface functions (all of the C<cmd_*> functions) just output
+error messages.
+
+=head2 C<%set>
+
+The C<%set> hash defines the mapping from command letter to subroutine
+name suffix.
+
+C<%set> is a two-level hash, indexed by set name and then by command name.
+Note that trying to set the CommandSet to 'foobar' simply results in the
+5.8.0 command set being used, since there's no top-level entry for 'foobar'.
+
+=cut
+
+### The API section
+
+my %set = ( #
+ 'pre580' => {
+ 'a' => 'pre580_a',
+ 'A' => 'pre580_null',
+ 'b' => 'pre580_b',
+ 'B' => 'pre580_null',
+ 'd' => 'pre580_null',
+ 'D' => 'pre580_D',
+ 'h' => 'pre580_h',
+ 'M' => 'pre580_null',
+ 'O' => 'o',
+ 'o' => 'pre580_null',
+ 'v' => 'M',
+ 'w' => 'v',
+ 'W' => 'pre580_W',
+ },
+ 'pre590' => {
+ '<' => 'pre590_prepost',
+ '<<' => 'pre590_prepost',
+ '>' => 'pre590_prepost',
+ '>>' => 'pre590_prepost',
+ '{' => 'pre590_prepost',
+ '{{' => 'pre590_prepost',
+ },
+ );
+
+=head2 C<cmd_wrapper()> (API)
+
+C<cmd_wrapper()> allows the debugger to switch command sets
+depending on the value of the C<CommandSet> option.
+
+It tries to look up the command in the X<C<%set>> package-level I<lexical>
+(which means external entities can't fiddle with it) and create the name of
+the sub to call based on the value found in the hash (if it's there). I<All>
+of the commands to be handled in a set have to be added to C<%set>; if they
+aren't found, the 5.8.0 equivalent is called (if there is one).
+
+This code uses symbolic references.
+
+=cut
+
+sub cmd_wrapper {
+ my $cmd = shift;
+ my $line = shift;
+ my $dblineno = shift;
+
+ # Assemble the command subroutine's name by looking up the
+ # command set and command name in %set. If we can't find it,
+ # default to the older version of the command.
+ my $call = 'cmd_'
+ . ( $set{$CommandSet}{$cmd}
+ || ( $cmd =~ /^[<>{]+/o ? 'prepost' : $cmd ) );
+
+ # Call the command subroutine, call it by name.
+ return &$call($cmd, $line, $dblineno);
+} ## end sub cmd_wrapper
+
+=head3 C<cmd_a> (command)
+
+The C<a> command handles pre-execution actions. These are associated with a
+particular line, so they're stored in C<%dbline>. We default to the current
+line if none is specified.
+
+=cut
+
+sub cmd_a {
+ my $cmd = shift;
+ my $line = shift || ''; # [.|line] expr
+ my $dbline = shift;
+
+ # If it's dot (here), or not all digits, use the current line.
+ $line =~ s/^(\.|(?:[^\d]))/$dbline/;
+
+ # Should be a line number followed by an expression.
+ if ($line =~ /^\s*(\d*)\s*(\S.+)/) {
+ my ($lineno, $expr) = ($1, $2);
+
+ # If we have an expression ...
+ if (length $expr) {
+ # ... but the line isn't breakable, complain.
+ if ($dbline[$lineno] == 0) {
+ print $OUT
+ "Line $lineno($dbline[$lineno]) does not have an action?\n";
+ }
+ else {
+ # It's executable. Record that the line has an action.
+ $had_breakpoints{$filename} |= 2;
+
+ # Remove any action, temp breakpoint, etc.
+ $dbline{$lineno} =~ s/\0[^\0]*//;
+
+ # Add the action to the line.
+ $dbline{$lineno} .= "\0" . action($expr);
+ }
+ } ## end if (length $expr)
+ } ## end if ($line =~ /^\s*(\d*)\s*(\S.+)/)
+ else {
+ # Syntax wrong.
+ print $OUT
+ "Adding an action requires an optional lineno and an expression\n"
+ ; # hint
+ }
+} ## end sub cmd_a
+
+=head3 C<cmd_A> (command)
+
+Delete actions. Similar to above, except the delete code is in a separate
+subroutine, C<delete_action>.
+
+=cut
+
+sub cmd_A {
+ my $cmd = shift;
+ my $line = shift || '';
+ my $dbline = shift;
+
+ # Dot is this line.
+ $line =~ s/^\./$dbline/;
+
+ # Call delete_action with a null param to delete them all.
+ # The '1' forces the eval to be true. It'll be false only
+ # if delete_action blows up for some reason, in which case
+ # we print $@ and get out.
+ if ($line eq '*') {
+ eval { &delete_action(); 1 } or print $OUT $@ and return;
+ }
+
+ # There's a real line number. Pass it to delete_action.
+ # Error trapping is as above.
+ elsif ($line =~ /^(\S.*)/) {
+ eval { &delete_action($1); 1 } or print $OUT $@ and return;
+ }
+
+ # Swing and a miss. Bad syntax.
+ else {
+ print $OUT
+ "Deleting an action requires a line number, or '*' for all\n"
+ ; # hint
+ }
+} ## end sub cmd_A
+
+=head3 C<delete_action> (API)
+
+C<delete_action> accepts either a line number or C<undef>. If a line number
+is specified, we check for the line being executable (if it's not, it
+couldn't have had an action). If it is, we just take the action off (this
+will get any kind of an action, including breakpoints).
+
+=cut
+
+sub delete_action {
+ my $i = shift;
+ if (defined($i)) {
+ # Can there be one?
+ die "Line $i has no action .\n" if $dbline[$i] == 0;
+
+ # Nuke whatever's there.
+ $dbline{$i} =~ s/\0[^\0]*//; # \^a
+ delete $dbline{$i} if $dbline{$i} eq '';
+ }
+ else {
+ print $OUT "Deleting all actions...\n";
+ for my $file (keys %had_breakpoints) {
+ local *dbline = $main::{ '_<' . $file };
+ my $max = $#dbline;
+ my $was;
+ for ($i = 1 ; $i <= $max ; $i++) {
+ if (defined $dbline{$i}) {
+ $dbline{$i} =~ s/\0[^\0]*//;
+ delete $dbline{$i} if $dbline{$i} eq '';
+ }
+ unless ($had_breakpoints{$file} &= ~2) {
+ delete $had_breakpoints{$file};
+ }
+ } ## end for ($i = 1 ; $i <= $max...
+ } ## end for my $file (keys %had_breakpoints)
+ } ## end else [ if (defined($i))
+} ## end sub delete_action
+
+=head3 C<cmd_b> (command)
+
+Set breakpoints. Since breakpoints can be set in so many places, in so many
+ways, conditionally or not, the breakpoint code is kind of complex. Mostly,
+we try to parse the command type, and then shuttle it off to an appropriate
+subroutine to actually do the work of setting the breakpoint in the right
+place.
+
+=cut
+
+sub cmd_b {
+ my $cmd = shift;
+ my $line = shift; # [.|line] [cond]
+ my $dbline = shift;
+
+ # Make . the current line number if it's there..
+ $line =~ s/^\./$dbline/;
+
+ # No line number, no condition. Simple break on current line.
+ if ($line =~ /^\s*$/) {
+ &cmd_b_line($dbline, 1);
+ }
+
+ # Break on load for a file.
+ elsif ($line =~ /^load\b\s*(.*)/) {
+ my $file = $1;
+ $file =~ s/\s+$//;
+ &cmd_b_load($file);
+ }
+
+ # b compile|postpone <some sub> [<condition>]
+ # The interpreter actually traps this one for us; we just put the
+ # necessary condition in the %postponed hash.
+ elsif ($line =~ /^(postpone|compile)\b\s*([':A-Za-z_][':\w]*)\s*(.*)/) {
+ # Capture the condition if there is one. Make it true if none.
+ my $cond = length $3 ? $3 : '1';
+
+ # Save the sub name and set $break to 1 if $1 was 'postpone', 0
+ # if it was 'compile'.
+ my ($subname, $break) = ($2, $1 eq 'postpone');
+
+ # De-Perl4-ify the name - ' separators to ::.
+ $subname =~ s/\'/::/g;
+
+ # Qualify it into the current package unless it's already qualified.
+ $subname = "${'package'}::" . $subname unless $subname =~ /::/;
+
+ # Add main if it starts with ::.
+ $subname = "main" . $subname if substr($subname, 0, 2) eq "::";
+
+ # Save the break type for this sub.
+ $postponed{$subname} = $break ? "break +0 if $cond" : "compile";
+ } ## end elsif ($line =~ ...
+
+ # b <sub name> [<condition>]
+ elsif ($line =~ /^([':A-Za-z_][':\w]*(?:\[.*\])?)\s*(.*)/) {
+ #
+ $subname = $1;
+ $cond = length $2 ? $2 : '1';
+ &cmd_b_sub($subname, $cond);
+ }
+
+ # b <line> [<condition>].
+ elsif ($line =~ /^(\d*)\s*(.*)/) {
+ # Capture the line. If none, it's the current line.
+ $line = $1 || $dbline;
+
+ # If there's no condition, make it '1'.
+ $cond = length $2 ? $2 : '1';
+
+ # Break on line.
+ &cmd_b_line($line, $cond);
+ }
+
+ # Line didn't make sense.
+ else {
+ print "confused by line($line)?\n";
+ }
+} ## end sub cmd_b
+
+=head3 C<break_on_load> (API)
+
+We want to break when this file is loaded. Mark this file in the
+C<%break_on_load> hash, and note that it has a breakpoint in
+C<%had_breakpoints>.
+
+=cut
+
+sub break_on_load {
+ my $file = shift;
+ $break_on_load{$file} = 1;
+ $had_breakpoints{$file} |= 1;
+}
+
+=head3 C<report_break_on_load> (API)
+
+Gives us an array of filenames that are set to break on load. Note that
+only files with break-on-load are in here, so simply showing the keys
+suffices.
+
+=cut
+
+sub report_break_on_load {
+ sort keys %break_on_load;
+}
+
+=head3 C<cmd_b_load> (command)
+
+We take the file passed in and try to find it in C<%INC> (which maps modules
+to files they came from). We mark those files for break-on-load via
+C<break_on_load> and then report that it was done.
+
+=cut
+
+sub cmd_b_load {
+ my $file = shift;
+ my @files;
+
+ # This is a block because that way we can use a redo inside it
+ # even without there being any looping structure at all outside it.
+ {
+ # Save short name and full path if found.
+ push @files, $file;
+ push @files, $::INC{$file} if $::INC{$file};
+
+ # Tack on .pm and do it again unless there was a '.' in the name
+ # already.
+ $file .= '.pm', redo unless $file =~ /\./;
+ }
+
+ # Do the real work here.
+ break_on_load($_) for @files;
+
+ # All the files that have break-on-load breakpoints.
+ @files = report_break_on_load;
+
+ # Normalize for the purposes of our printing this.
+ local $\ = '';
+ local $" = ' ';
+ print $OUT "Will stop on load of `@files'.\n";
+} ## end sub cmd_b_load
+
+=head3 C<$filename_error> (API package global)
+
+Several of the functions we need to implement in the API need to work both
+on the current file and on other files. We don't want to duplicate code, so
+C<$filename_error> is used to contain the name of the file that's being
+worked on (if it's not the current one).
+
+We can now build functions in pairs: the basic function works on the current
+file, and uses C<$filename_error> as part of its error message. Since this is
+initialized to C<''>, no filename will appear when we are working on the
+current file.
+
+The second function is a wrapper which does the following:
+
+=over 4
+
+=item * Localizes C<$filename_error> and sets it to the name of the file to be processed.
+
+=item * Locaizes the C<*dbline> glob and reassigns it to point to the file we want to process.
+
+=item * Calls the first function.
+
+The first function works on the "current" (i.e., the one we changed to) file,
+and prints C<$filename_error> in the error message (the name of the other file)
+if it needs to. When the functions return, C<*dbline> is restored to point to the actual current file (the one we're executing in) and C<$filename_error> is
+restored to C<''>. This restores everything to the way it was before the
+second function was called at all.
+
+See the comments in C<breakable_line> and C<breakable_line_in_file> for more
+details.
+
+=cut
+
+$filename_error = '';
+
+=head3 breakable_line($from, $to) (API)
+
+The subroutine decides whether or not a line in the current file is breakable.
+It walks through C<@dbline> within the range of lines specified, looking for
+the first line that is breakable.
+
+If C<$to> is greater than C<$from>, the search moves forwards, finding the
+first line I<after> C<$to> that's breakable, if there is one.
+
+If C<$from> is greater than C<$to>, the search goes I<backwards>, finding the
+first line I<before> C<$to> that's breakable, if there is one.
+
+=cut
+
+sub breakable_line {
+
+ my ($from, $to) = @_;
+
+ # $i is the start point. (Where are the FORTRAN programs of yesteryear?)
+ my $i = $from;
+
+ # If there are at least 2 arguments, we're trying to search a range.
+ if (@_ >= 2) {
+
+ # $delta is positive for a forward search, negative for a backward one.
+ my $delta = $from < $to ? +1 : -1;
+
+ # Keep us from running off the ends of the file.
+ my $limit = $delta > 0 ? $#dbline : 1;
+
+ # Clever test. If you're a mathematician, it's obvious why this
+ # test works. If not:
+ # If $delta is positive (going forward), $limit will be $#dbline.
+ # If $to is less than $limit, ($limit - $to) will be positive, times
+ # $delta of 1 (positive), so the result is > 0 and we should use $to
+ # as the stopping point.
+ #
+ # If $to is greater than $limit, ($limit - $to) is negative,
+ # times $delta of 1 (positive), so the result is < 0 and we should
+ # use $limit ($#dbline) as the stopping point.
+ #
+ # If $delta is negative (going backward), $limit will be 1.
+ # If $to is zero, ($limit - $to) will be 1, times $delta of -1
+ # (negative) so the result is > 0, and we use $to as the stopping
+ # point.
+ #
+ # If $to is less than zero, ($limit - $to) will be positive,
+ # times $delta of -1 (negative), so the result is not > 0, and
+ # we use $limit (1) as the stopping point.
+ #
+ # If $to is 1, ($limit - $to) will zero, times $delta of -1
+ # (negative), still giving zero; the result is not > 0, and
+ # we use $limit (1) as the stopping point.
+ #
+ # if $to is >1, ($limit - $to) will be negative, times $delta of -1
+ # (negative), giving a positive (>0) value, so we'll set $limit to
+ # $to.
+
+ $limit = $to if ($limit - $to) * $delta > 0;
+
+ # The real search loop.
+ # $i starts at $from (the point we want to start searching from).
+ # We move through @dbline in the appropriate direction (determined
+ # by $delta: either -1 (back) or +1 (ahead).
+ # We stay in as long as we haven't hit an executable line
+ # ($dbline[$i] == 0 means not executable) and we haven't reached
+ # the limit yet (test similar to the above).
+ $i += $delta while $dbline[$i] == 0 and ($limit - $i) * $delta > 0;
+
+ } ## end if (@_ >= 2)
+
+ # If $i points to a line that is executable, return that.
+ return $i unless $dbline[$i] == 0;
+
+ # Format the message and print it: no breakable lines in range.
+ my ($pl, $upto) = ('', '');
+ ($pl, $upto) = ('s', "..$to") if @_ >= 2 and $from != $to;
+
+ # If there's a filename in filename_error, we'll see it.
+ # If not, not.
+ die "Line$pl $from$upto$filename_error not breakable\n";
+} ## end sub breakable_line
+
+=head3 breakable_line_in_filename($file, $from, $to) (API)
+
+Like C<breakable_line>, but look in another file.
+
+=cut
+
+sub breakable_line_in_filename {
+ # Capture the file name.
+ my ($f) = shift;
+
+ # Swap the magic line array over there temporarily.
+ local *dbline = $main::{ '_<' . $f };
+
+ # If there's an error, it's in this other file.
+ local $filename_error = " of `$f'";
+
+ # Find the breakable line.
+ breakable_line(@_);
+
+ # *dbline and $filename_error get restored when this block ends.
+
+} ## end sub breakable_line_in_filename
+
+=head3 break_on_line(lineno, [condition]) (API)
+
+Adds a breakpoint with the specified codition (or 1 if no condition was
+specified) to the specified line. Dies if it can't.
+
+=cut
+
+sub break_on_line {
+ my ($i, $cond) = @_;
+
+ # Always true if no condition supplied.
+ $cond = 1 unless @_ >= 2;
+
+ my $inii = $i;
+ my $after = '';
+ my $pl = '';
+
+ # Woops, not a breakable line. $filename_error allows us to say
+ # if it was in a different file.
+ die "Line $i$filename_error not breakable.\n" if $dbline[$i] == 0;
+
+ # Mark this file as having breakpoints in it.
+ $had_breakpoints{$filename} |= 1;
+
+ # If there is an action or condition here already ...
+ if ($dbline{$i}) {
+ # ... swap this condition for the existing one.
+ $dbline{$i} =~ s/^[^\0]*/$cond/;
+ }
+ else {
+ # Nothing here - just add the condition.
+ $dbline{$i} = $cond;
+ }
+} ## end sub break_on_line
+
+=head3 cmd_b_line(line, [condition]) (command)
+
+Wrapper for C<break_on_line>. Prints the failure message if it
+doesn't work.
+
+=cut
+
+sub cmd_b_line {
+ eval { break_on_line(@_); 1 } or do {
+ local $\ = '';
+ print $OUT $@ and return;
+ };
+} ## end sub cmd_b_line
+
+=head3 break_on_filename_line(file, line, [condition]) (API)
+
+Switches to the file specified and then calls C<break_on_line> to set
+the breakpoint.
+
+=cut
+
+sub break_on_filename_line {
+ my ($f, $i, $cond) = @_;
+
+ # Always true if condition left off.
+ $cond = 1 unless @_ >= 3;
+
+ # Switch the magical hash temporarily.
+ local *dbline = $main::{ '_<' . $f };
+
+ # Localize the variables that break_on_line uses to make its message.
+ local $filename_error = " of `$f'";
+ local $filename = $f;
+
+ # Add the breakpoint.
+ break_on_line($i, $cond);
+} ## end sub break_on_filename_line
+
+=head3 break_on_filename_line_range(file, from, to, [condition]) (API)
+
+Switch to another file, search the range of lines specified for an
+executable one, and put a breakpoint on the first one you find.
+
+=cut
+
+sub break_on_filename_line_range {
+ my ($f, $from, $to, $cond) = @_;
+
+ # Find a breakable line if there is one.
+ my $i = breakable_line_in_filename($f, $from, $to);
+
+ # Always true if missing.
+ $cond = 1 unless @_ >= 3;
+
+ # Add the breakpoint.
+ break_on_filename_line($f, $i, $cond);
+} ## end sub break_on_filename_line_range
+
+=head3 subroutine_filename_lines(subname, [condition]) (API)
+
+Search for a subroutine within a given file. The condition is ignored.
+Uses C<find_sub> to locate the desired subroutine.
+
+=cut
+
+sub subroutine_filename_lines {
+ my ($subname, $cond) = @_;
+
+ # Returned value from find_sub() is fullpathname:startline-endline.
+ # The match creates the list (fullpathname, start, end). Falling off
+ # the end of the subroutine returns this implicitly.
+ find_sub($subname) =~ /^(.*):(\d+)-(\d+)$/;
+} ## end sub subroutine_filename_lines
+
+=head3 break_subroutine(subname) (API)
+
+Places a break on the first line possible in the specified subroutine. Uses
+C<subroutine_filename_lines> to find the subroutine, and
+C<break_on_filename_line_range> to place the break.
+
+=cut
+
+sub break_subroutine {
+ my $subname = shift;
+
+ # Get filename, start, and end.
+ my ($file, $s, $e) = subroutine_filename_lines($subname)
+ or die "Subroutine $subname not found.\n";
+
+ # Null condition changes to '1' (always true).
+ $cond = 1 unless @_ >= 2;
+
+ # Put a break the first place possible in the range of lines
+ # that make up this subroutine.
+ break_on_filename_line_range($file, $s, $e, @_);
+} ## end sub break_subroutine
+
+=head3 cmd_b_sub(subname, [condition]) (command)
+
+We take the incoming subroutine name and fully-qualify it as best we can.
+
+=over 4
+
+=item 1. If it's already fully-qualified, leave it alone.
+
+=item 2. Try putting it in the current package.
+
+=item 3. If it's not there, try putting it in CORE::GLOBAL if it exists there.
+
+=item 4. If it starts with '::', put it in 'main::'.
+
+=back
+
+After all this cleanup, we call C<break_subroutine> to try to set the
+breakpoint.
+
+=cut
+
+sub cmd_b_sub {
+ my ($subname, $cond) = @_;
+
+ # Add always-true condition if we have none.
+ $cond = 1 unless @_ >= 2;
+
+ # If the subname isn't a code reference, qualify it so that
+ # break_subroutine() will work right.
+ unless (ref $subname eq 'CODE') {
+ # Not Perl4.
+ $subname =~ s/\'/::/g;
+ my $s = $subname;
+
+ # Put it in this package unless it's already qualified.
+ $subname = "${'package'}::" . $subname
+ unless $subname =~ /::/;
+
+ # Requalify it into CORE::GLOBAL if qualifying it into this
+ # package resulted in its not being defined, but only do so
+ # if it really is in CORE::GLOBAL.
+ $subname = "CORE::GLOBAL::$s"
+ if not defined &$subname
+ and $s !~ /::/
+ and defined &{"CORE::GLOBAL::$s"};
+
+ # Put it in package 'main' if it has a leading ::.
+ $subname = "main" . $subname if substr($subname, 0, 2) eq "::";
+
+ } ## end unless (ref $subname eq 'CODE')
+
+ # Try to set the breakpoint.
+ eval { break_subroutine($subname, $cond); 1 } or do {
+ local $\ = '';
+ print $OUT $@ and return;
+ }
+} ## end sub cmd_b_sub
+
+=head3 C<cmd_B> - delete breakpoint(s) (command)
+
+The command mostly parses the command line and tries to turn the argument
+into a line spec. If it can't, it uses the current line. It then calls
+C<delete_breakpoint> to actually do the work.
+
+If C<*> is specified, C<cmd_B> calls C<delete_breakpoint> with no arguments,
+thereby deleting all the breakpoints.
+
+=cut
+
+sub cmd_B {
+ my $cmd = shift;
+
+ # No line spec? Use dbline.
+ # If there is one, use it if it's non-zero, or wipe it out if it is.
+ my $line = ($_[0] =~ /^\./) ? $dbline : shift || '';
+ my $dbline = shift;
+
+ # If the line was dot, make the line the current one.
+ $line =~ s/^\./$dbline/;
+
+ # If it's * we're deleting all the breakpoints.
+ if ($line eq '*') {
+ eval { &delete_breakpoint(); 1 } or print $OUT $@ and return;
+ }
+
+ # If there is a line spec, delete the breakpoint on that line.
+ elsif ($line =~ /^(\S.*)/) {
+ eval { &delete_breakpoint($line || $dbline); 1 } or do {
+ local $\ = '';
+ print $OUT $@ and return;
+ };
+ } ## end elsif ($line =~ /^(\S.*)/)
+
+ # No line spec.
+ else {
+ print $OUT
+ "Deleting a breakpoint requires a line number, or '*' for all\n"
+ ; # hint
+ }
+} ## end sub cmd_B
+
+=head3 delete_breakpoint([line]) (API)
+
+This actually does the work of deleting either a single breakpoint, or all
+of them.
+
+For a single line, we look for it in C<@dbline>. If it's nonbreakable, we
+just drop out with a message saying so. If it is, we remove the condition
+part of the 'condition\0action' that says there's a breakpoint here. If,
+after we've done that, there's nothing left, we delete the corresponding
+line in C<%dbline> to signal that no action needs to be taken for this line.
+
+For all breakpoints, we iterate through the keys of C<%had_breakpoints>,
+which lists all currently-loaded files which have breakpoints. We then look
+at each line in each of these files, temporarily switching the C<%dbline>
+and C<@dbline> structures to point to the files in question, and do what
+we did in the single line case: delete the condition in C<@dbline>, and
+delete the key in C<%dbline> if nothing's left.
+
+We then wholesale delete C<%postponed>, C<%postponed_file>, and
+C<%break_on_load>, because these structures contain breakpoints for files
+and code that haven't been loaded yet. We can just kill these off because there
+are no magical debugger structures associated with them.
+
+=cut
+
+sub delete_breakpoint {
+ my $i = shift;
+
+ # If we got a line, delete just that one.
+ if (defined($i)) {
+
+ # Woops. This line wasn't breakable at all.
+ die "Line $i not breakable.\n" if $dbline[$i] == 0;
+
+ # Kill the condition, but leave any action.
+ $dbline{$i} =~ s/^[^\0]*//;
+
+ # Remove the entry entirely if there's no action left.
+ delete $dbline{$i} if $dbline{$i} eq '';
+ }
+
+ # No line; delete them all.
+ else {
+ print $OUT "Deleting all breakpoints...\n";
+
+ # %had_breakpoints lists every file that had at least one
+ # breakpoint in it.
+ for my $file (keys %had_breakpoints) {
+ # Switch to the desired file temporarily.
+ local *dbline = $main::{ '_<' . $file };
+
+ my $max = $#dbline;
+ my $was;
+
+ # For all lines in this file ...
+ for ($i = 1 ; $i <= $max ; $i++) {
+ # If there's a breakpoint or action on this line ...
+ if (defined $dbline{$i}) {
+ # ... remove the breakpoint.
+ $dbline{$i} =~ s/^[^\0]+//;
+ if ($dbline{$i} =~ s/^\0?$//) {
+ # Remove the entry altogether if no action is there.
+ delete $dbline{$i};
+ }
+ } ## end if (defined $dbline{$i...
+ } ## end for ($i = 1 ; $i <= $max...
+
+ # If, after we turn off the "there were breakpoints in this file"
+ # bit, the entry in %had_breakpoints for this file is zero,
+ # we should remove this file from the hash.
+ if (not $had_breakpoints{$file} &= ~1) {
+ delete $had_breakpoints{$file};
+ }
+ } ## end for my $file (keys %had_breakpoints)
+
+ # Kill off all the other breakpoints that are waiting for files that
+ # haven't been loaded yet.
+ undef %postponed;
+ undef %postponed_file;
+ undef %break_on_load;
+ } ## end else [ if (defined($i))
+} ## end sub delete_breakpoint
+
+=head3 cmd_stop (command)
+
+This is meant to be part of the new command API, but it isn't called or used
+anywhere else in the debugger. XXX It is probably meant for use in development
+of new commands.
+
+=cut
+
+sub cmd_stop { # As on ^C, but not signal-safy.
+ $signal = 1;
+}
+
+=head3 C<cmd_h> - help command (command)
+
+Does the work of either
+
+=over 4
+
+=item * Showing all the debugger help
+
+=item * Showing help for a specific command
+
+=back
+
+=cut
+
+sub cmd_h {
+ my $cmd = shift;
+
+ # If we have no operand, assume null.
+ my $line = shift || '';
+
+ # 'h h'. Print the long-format help.
+ if ($line =~ /^h\s*/) {
+ print_help($help);
+ }
+
+ # 'h <something>'. Search for the command and print only its help.
+ elsif ($line =~ /^(\S.*)$/) {
+
+ # support long commands; otherwise bogus errors
+ # happen when you ask for h on <CR> for example
+ my $asked = $1; # the command requested
+ # (for proper error message)
+
+ my $qasked = quotemeta($asked); # for searching; we don't
+ # want to use it as a pattern.
+ # XXX: finds CR but not <CR>
+
+ # Search the help string for the command.
+ if ($help =~ /^ # Start of a line
+ <? # Optional '<'
+ (?:[IB]<) # Optional markup
+ $qasked # The requested command
+ /mx) {
+ # It's there; pull it out and print it.
+ while ($help =~ /^
+ (<? # Optional '<'
+ (?:[IB]<) # Optional markup
+ $qasked # The command
+ ([\s\S]*?) # Description line(s)
+ \n) # End of last description line
+ (?!\s) # Next line not starting with
+ # whitespace
+ /mgx) {
+ print_help($1);
+ }
+ }
+
+ # Not found; not a debugger command.
+ else {
+ print_help("B<$asked> is not a debugger command.\n");
+ }
+ } ## end elsif ($line =~ /^(\S.*)$/)
+
+ # 'h' - print the summary help.
+ else {
+ print_help($summary);
+ }
+} ## end sub cmd_h
+
+=head3 C<cmd_l> - list lines (command)
+
+Most of the command is taken up with transforming all the different line
+specification syntaxes into 'start-stop'. After that is done, the command
+runs a loop over C<@dbline> for the specified range of lines. It handles
+the printing of each line and any markers (C<==E<gt>> for current line,
+C<b> for break on this line, C<a> for action on this line, C<:> for this
+line breakable).
+
+We save the last line listed in the C<$start> global for further listing
+later.
+
+=cut
+
+sub cmd_l {
+ my $current_line = shift;
+ my $line = shift;
+
+ # If this is '-something', delete any spaces after the dash.
+ $line =~ s/^-\s*$/-/;
+
+ # If the line is '$something', assume this is a scalar containing a
+ # line number.
+ if ($line =~ /^(\$.*)/s) {
+
+ # Set up for DB::eval() - evaluate in *user* context.
+ $evalarg = $2;
+ my ($s) = &eval;
+
+ # Ooops. Bad scalar.
+ print($OUT "Error: $@\n"), next CMD if $@;
+
+ # Good scalar. If it's a reference, find what it points to.
+ $s = CvGV_name($s);
+ print($OUT "Interpreted as: $1 $s\n");
+ $line = "$1 $s";
+
+ # Call self recursively to really do the command.
+ &cmd_l('l', $s);
+ } ## end if ($line =~ /^(\$.*)/s)
+
+ # l name. Try to find a sub by that name.
+ elsif ($line =~ /^([\':A-Za-z_][\':\w]*(\[.*\])?)/s) {
+ my $s = $subname = $1;
+
+ # De-Perl4.
+ $subname =~ s/\'/::/;
+
+ # Put it in this package unless it starts with ::.
+ $subname = $package . "::" . $subname unless $subname =~ /::/;
+
+ # Put it in CORE::GLOBAL if t doesn't start with :: and
+ # it doesn't live in this package and it lives in CORE::GLOBAL.
+ $subname = "CORE::GLOBAL::$s"
+ if not defined &$subname
+ and $s !~ /::/
+ and defined &{"CORE::GLOBAL::$s"};
+
+ # Put leading '::' names into 'main::'.
+ $subname = "main" . $subname if substr($subname, 0, 2) eq "::";
+
+ # Get name:start-stop from find_sub, and break this up at
+ # colons.
+ @pieces = split (/:/, find_sub($subname) || $sub{$subname});
+
+ # Pull off start-stop.
+ $subrange = pop @pieces;
+
+ # If the name contained colons, the split broke it up.
+ # Put it back together.
+ $file = join (':', @pieces);
+
+ # If we're not in that file, switch over to it.
+ if ($file ne $filename) {
+ print $OUT "Switching to file '$file'.\n"
+ unless $slave_editor;
+
+ # Switch debugger's magic structures.
+ *dbline = $main::{ '_<' . $file };
+ $max = $#dbline;
+ $filename = $file;
+ } ## end if ($file ne $filename)
+
+ # Subrange is 'start-stop'. If this is less than a window full,
+ # swap it to 'start+', which will list a window from the start point.
+ if ($subrange) {
+ if (eval($subrange) < -$window) {
+ $subrange =~ s/-.*/+/;
+ }
+ # Call self recursively to list the range.
+ $line = $subrange;
+ &cmd_l('l', $subrange);
+ } ## end if ($subrange)
+
+ # Couldn't find it.
+ else {
+ print $OUT "Subroutine $subname not found.\n";
+ }
+ } ## end elsif ($line =~ /^([\':A-Za-z_][\':\w]*(\[.*\])?)/s)
+
+ # Bare 'l' command.
+ elsif ($line =~ /^\s*$/) {
+ # Compute new range to list.
+ $incr = $window - 1;
+ $line = $start . '-' . ($start + $incr);
+ # Recurse to do it.
+ &cmd_l('l', $line);
+ }
+
+ # l [start]+number_of_lines
+ elsif ($line =~ /^(\d*)\+(\d*)$/) {
+ # Don't reset start for 'l +nnn'.
+ $start = $1 if $1;
+
+ # Increment for list. Use window size if not specified.
+ # (Allows 'l +' to work.)
+ $incr = $2;
+ $incr = $window - 1 unless $incr;
+
+ # Create a line range we'll understand, and recurse to do it.
+ $line = $start . '-' . ($start + $incr);
+ &cmd_l('l', $line);
+ } ## end elsif ($line =~ /^(\d*)\+(\d*)$/)
+
+ # l start-stop or l start,stop
+ elsif ($line =~ /^((-?[\d\$\.]+)([-,]([\d\$\.]+))?)?/) {
+
+ # Determine end point; use end of file if not specified.
+ $end = (!defined $2) ? $max : ($4 ? $4 : $2);
+
+ # Go on to the end, and then stop.
+ $end = $max if $end > $max;
+
+ # Determine start line.
+ $i = $2;
+ $i = $line if $i eq '.';
+ $i = 1 if $i < 1;
+ $incr = $end - $i;
+
+ # If we're running under a slave editor, force it to show the lines.
+ if ($slave_editor) {
+ print $OUT "\032\032$filename:$i:0\n";
+ $i = $end;
+ }
+
+ # We're doing it ourselves. We want to show the line and special
+ # markers for:
+ # - the current line in execution
+ # - whether a line is breakable or not
+ # - whether a line has a break or not
+ # - whether a line has an action or not
+ else {
+ for (; $i <= $end ; $i++) {
+ # Check for breakpoints and actions.
+ my ($stop, $action);
+ ($stop, $action) = split (/\0/, $dbline{$i})
+ if $dbline{$i};
+
+ # ==> if this is the current line in execution,
+ # : if it's breakable.
+ $arrow =
+ ($i == $current_line and $filename eq $filename_ini)
+ ? '==>'
+ : ($dbline[$i] + 0 ? ':' : ' ');
+
+ # Add break and action indicators.
+ $arrow .= 'b' if $stop;
+ $arrow .= 'a' if $action;
+
+ # Print the line.
+ print $OUT "$i$arrow\t", $dbline[$i];
+
+ # Move on to the next line. Drop out on an interrupt.
+ $i++, last if $signal;
+ } ## end for (; $i <= $end ; $i++)
+
+ # Line the prompt up; print a newline if the last line listed
+ # didn't have a newline.
+ print $OUT "\n" unless $dbline[$i - 1] =~ /\n$/;
+ } ## end else [ if ($slave_editor)
+
+ # Save the point we last listed to in case another relative 'l'
+ # command is desired. Don't let it run off the end.
+ $start = $i;
+ $start = $max if $start > $max;
+ } ## end elsif ($line =~ /^((-?[\d\$\.]+)([-,]([\d\$\.]+))?)?/)
+} ## end sub cmd_l
+
+=head3 C<cmd_L> - list breakpoints, actions, and watch expressions (command)
+
+To list breakpoints, the command has to look determine where all of them are
+first. It starts a C<%had_breakpoints>, which tells us what all files have
+breakpoints and/or actions. For each file, we switch the C<*dbline> glob (the
+magic source and breakpoint data structures) to the file, and then look
+through C<%dbline> for lines with breakpoints and/or actions, listing them
+out. We look through C<%postponed> not-yet-compiled subroutines that have
+breakpoints, and through C<%postponed_file> for not-yet-C<require>'d files
+that have breakpoints.
+
+Watchpoints are simpler: we just list the entries in C<@to_watch>.
+
+=cut
+
+sub cmd_L {
+ my $cmd = shift;
+
+ # If no argument, list everything. Pre-5.8.0 version always lists
+ # everything
+ my $arg = shift || 'abw';
+ $arg = 'abw' unless $CommandSet eq '580'; # sigh...
+
+ # See what is wanted.
+ my $action_wanted = ($arg =~ /a/) ? 1 : 0;
+ my $break_wanted = ($arg =~ /b/) ? 1 : 0;
+ my $watch_wanted = ($arg =~ /w/) ? 1 : 0;
+
+ # Breaks and actions are found together, so we look in the same place
+ # for both.
+ if ($break_wanted or $action_wanted) {
+ # Look in all the files with breakpoints...
+ for my $file (keys %had_breakpoints) {
+ # Temporary switch to this file.
+ local *dbline = $main::{ '_<' . $file };
+
+ # Set up to look through the whole file.
+ my $max = $#dbline;
+ my $was; # Flag: did we print something
+ # in this file?
+
+ # For each line in the file ...
+ for ($i = 1 ; $i <= $max ; $i++) {
+ # We've got something on this line.
+ if (defined $dbline{$i}) {
+ # Print the header if we haven't.
+ print $OUT "$file:\n" unless $was++;
+
+ # Print the line.
+ print $OUT " $i:\t", $dbline[$i];
+
+ # Pull out the condition and the action.
+ ($stop, $action) = split (/\0/, $dbline{$i});
+
+ # Print the break if there is one and it's wanted.
+ print $OUT " break if (", $stop, ")\n"
+ if $stop
+ and $break_wanted;
+
+ # Print the action if there is one and it's wanted.
+ print $OUT " action: ", $action, "\n"
+ if $action
+ and $action_wanted;
+
+ # Quit if the user hit interrupt.
+ last if $signal;
+ } ## end if (defined $dbline{$i...
+ } ## end for ($i = 1 ; $i <= $max...
+ } ## end for my $file (keys %had_breakpoints)
+ } ## end if ($break_wanted or $action_wanted)
+
+ # Look for breaks in not-yet-compiled subs:
+ if (%postponed and $break_wanted) {
+ print $OUT "Postponed breakpoints in subroutines:\n";
+ my $subname;
+ for $subname (keys %postponed) {
+ print $OUT " $subname\t$postponed{$subname}\n";
+ last if $signal;
+ }
+ } ## end if (%postponed and $break_wanted)
+
+ # Find files that have not-yet-loaded breaks:
+ my @have = map { # Combined keys
+ keys %{ $postponed_file{$_} }
+ } keys %postponed_file;
+
+ # If there are any, list them.
+ if (@have and ($break_wanted or $action_wanted)) {
+ print $OUT "Postponed breakpoints in files:\n";
+ my ($file, $line);
+
+ for $file (keys %postponed_file) {
+ my $db = $postponed_file{$file};
+ print $OUT " $file:\n";
+ for $line (sort { $a <=> $b } keys %$db) {
+ print $OUT " $line:\n";
+ my ($stop, $action) = split (/\0/, $$db{$line});
+ print $OUT " break if (", $stop, ")\n"
+ if $stop
+ and $break_wanted;
+ print $OUT " action: ", $action, "\n"
+ if $action
+ and $action_wanted;
+ last if $signal;
+ } ## end for $line (sort { $a <=>...
+ last if $signal;
+ } ## end for $file (keys %postponed_file)
+ } ## end if (@have and ($break_wanted...
+ if (%break_on_load and $break_wanted) {
+ print $OUT "Breakpoints on load:\n";
+ my $file;
+ for $file (keys %break_on_load) {
+ print $OUT " $file\n";
+ last if $signal;
+ }
+ } ## end if (%break_on_load and...
+ if ($watch_wanted) {
+ if ($trace & 2) {
+ print $OUT "Watch-expressions:\n" if @to_watch;
+ for my $expr (@to_watch) {
+ print $OUT " $expr\n";
+ last if $signal;
+ }
+ } ## end if ($trace & 2)
+ } ## end if ($watch_wanted)
+} ## end sub cmd_L
+
+=head3 C<cmd_M> - list modules (command)
+
+Just call C<list_modules>.
+
+=cut
+
+sub cmd_M {
+ &list_modules();
+}
+
+=head3 C<cmd_o> - options (command)
+
+If this is just C<o> by itself, we list the current settings via
+C<dump_option>. If there's a nonblank value following it, we pass that on to
+C<parse_options> for processing.
+
+=cut
sub cmd_o {
- my $cmd = shift; # o
- my $opt = shift || ''; # opt[=val]
- if ($opt =~ /^(\S.*)/) {
- &parse_options($1);
- } else {
- for (@options) {
- &dump_option($_);
- }
- }
+ my $cmd = shift;
+ my $opt = shift || ''; # opt[=val]
+
+ # Nonblank. Try to parse and process.
+ if ($opt =~ /^(\S.*)/) {
+ &parse_options($1);
+ }
+
+ # Blank. List the current option settings.
+ else {
+ for (@options) {
+ &dump_option($_);
+ }
+ }
+} ## end sub cmd_o
+
+=head3 C<cmd_O> - nonexistent in 5.8.x (command)
+
+Advises the user that the O command has been renamed.
+
+=cut
+
+sub cmd_O {
+ print $OUT "The old O command is now the o command.\n"; # hint
+ print $OUT "Use 'h' to get current command help synopsis or\n"; #
+ print $OUT "use 'o CommandSet=pre580' to revert to old usage\n"; #
}
-sub cmd_O {
- print $OUT "The old O command is now the o command.\n"; # hint
- print $OUT "Use 'h' to get current command help synopsis or\n"; #
- print $OUT "use 'o CommandSet=pre580' to revert to old usage\n"; #
-}
+=head3 C<cmd_v> - view window (command)
+
+Uses the C<$preview> variable set in the second C<BEGIN> block (q.v.) to
+move back a few lines to list the selected line in context. Uses C<cmd_l>
+to do the actual listing after figuting out the range of line to request.
+
+=cut
+
+sub cmd_v {
+ my $cmd = shift;
+ my $line = shift;
+
+ # Extract the line to list around. (Astute readers will have noted that
+ # this pattern will match whether or not a numeric line is specified,
+ # which means that we'll always enter this loop (though a non-numeric
+ # argument results in no action at all)).
+ if ($line =~ /^(\d*)$/) {
+ # Total number of lines to list (a windowful).
+ $incr = $window - 1;
+
+ # Set the start to the argument given (if there was one).
+ $start = $1 if $1;
+
+ # Back up by the context amount.
+ $start -= $preview;
+
+ # Put together a linespec that cmd_l will like.
+ $line = $start . '-' . ($start + $incr);
-sub cmd_v {
- my $cmd = shift; # v
- my $line = shift;
-
- if ($line =~ /^(\d*)$/) {
- $incr = $window - 1;
- $start = $1 if $1;
- $start -= $preview;
- $line = $start . '-' . ($start + $incr);
- &cmd_l('l', $line);
- }
-}
+ # List the lines.
+ &cmd_l('l', $line);
+ } ## end if ($line =~ /^(\d*)$/)
+} ## end sub cmd_v
+
+=head3 C<cmd_w> - add a watch expression (command)
+
+The 5.8 version of this command adds a watch expression if one is specified;
+it does nothing if entered with no operands.
+
+We extract the expression, save it, evaluate it in the user's context, and
+save the value. We'll re-evaluate it each time the debugger passes a line,
+and will stop (see the code at the top of the command loop) if the value
+of any of the expressions changes.
+
+=cut
sub cmd_w {
- my $cmd = shift; # w
- my $expr = shift || '';
- if ($expr =~ /^(\S.*)/) {
- push @to_watch, $expr;
- $evalarg = $expr;
- my ($val) = join(' ', &eval);
- $val = (defined $val) ? "'$val'" : 'undef' ;
- push @old_watch, $val;
- $trace |= 2;
- } else {
- print $OUT "Adding a watch-expression requires an expression\n"; # hint
- }
-}
+ my $cmd = shift;
+
+ # Null expression if no arguments.
+ my $expr = shift || '';
+
+ # If expression is not null ...
+ if ($expr =~ /^(\S.*)/) {
+ # ... save it.
+ push @to_watch, $expr;
+
+ # Parameterize DB::eval and call it to get the expression's value
+ # in the user's context. This version can handle expressions which
+ # return a list value.
+ $evalarg = $expr;
+ my ($val) = join(' ', &eval);
+ $val = (defined $val) ? "'$val'" : 'undef';
+
+ # Save the current value of the expression.
+ push @old_watch, $val;
+
+ # We are now watching expressions.
+ $trace |= 2;
+ } ## end if ($expr =~ /^(\S.*)/)
+
+ # You have to give one to get one.
+ else {
+ print $OUT
+ "Adding a watch-expression requires an expression\n"; # hint
+ }
+} ## end sub cmd_w
+
+=head3 C<cmd_W> - delete watch expressions (command)
+
+This command accepts either a watch expression to be removed from the list
+of watch expressions, or C<*> to delete them all.
+
+If C<*> is specified, we simply empty the watch expression list and the
+watch expression value list. We also turn off the bit that says we've got
+watch expressions.
+
+If an expression (or partial expression) is specified, we pattern-match
+through the expressions and remove the ones that match. We also discard
+the corresponding values. If no watch expressions are left, we turn off
+the 'watching expressions' bit.
+
+=cut
sub cmd_W {
- my $cmd = shift; # W
- my $expr = shift || '';
- if ($expr eq '*') {
- $trace &= ~2;
- print $OUT "Deleting all watch expressions ...\n";
- @to_watch = @old_watch = ();
- } elsif ($expr =~ /^(\S.*)/) {
- my $i_cnt = 0;
- foreach (@to_watch) {
- my $val = $to_watch[$i_cnt];
- if ($val eq $expr) { # =~ m/^\Q$i$/) {
- splice(@to_watch, $i_cnt, 1);
- }
- $i_cnt++;
- }
- } else {
- print $OUT "Deleting a watch-expression requires an expression, or '*' for all\n"; # hint
- }
-}
+ my $cmd = shift;
+ my $expr = shift || '';
+ # Delete them all.
+ if ($expr eq '*') {
+ # Not watching now.
+ $trace &= ~2;
+ print $OUT "Deleting all watch expressions ...\n";
-sub cmd_P {
- if ($cmd =~ /^.\b\s*([+-]?)\s*(~?)\s*(\w+(\s*\|\s*\w+)*)\s*$/) {
- my ($how, $neg, $flags)=($1, $2, $3);
- my $acu=parse_DollarCaretP_flags($flags);
- if (defined $acu) {
- $acu= ~$acu if $neg;
- if ($how eq '+') { $^P|=$acu }
- elsif ($how eq '-') { $^P&=~$acu }
- else { $^P=$acu }
+ # And all gone.
+ @to_watch = @old_watch = ();
}
- # else { print $OUT "undefined acu\n" }
- }
- my $expanded=expand_DollarCaretP_flags($^P);
- print $OUT "Internal Perl debugger flags:\n\$^P=$expanded\n";
- $expanded
-}
+
+ # Delete one of them.
+ elsif ($expr =~ /^(\S.*)/) {
+ # Where we are in the list.
+ my $i_cnt = 0;
+
+ # For each expression ...
+ foreach (@to_watch) {
+ my $val = $to_watch[$i_cnt];
+
+ # Does this one match the command argument?
+ if ($val eq $expr) { # =~ m/^\Q$i$/) {
+ # Yes. Turn it off.
+ splice(@to_watch, $i_cnt, 1);
+ # We ought to kill the value too, oughtn't we?
+ # But we don't. XXX This is a bug.
+ }
+ $i_cnt++;
+ } ## end foreach (@to_watch)
+
+ # We probably should see if they're all gone. But we don't.
+ # No bug shows up for this because the 'check watch expressions'
+ # code iterates over the @to_watch array. Since it's empty, nothing
+ # untoward happens.
+ } ## end elsif ($expr =~ /^(\S.*)/)
+
+ # No command arguments entered.
+ else {
+ print $OUT
+"Deleting a watch-expression requires an expression, or '*' for all\n"
+ ; # hint
+ }
+} ## end sub cmd_W
### END of the API section
+=head1 SUPPORT ROUTINES
+
+These are general support routines that are used in a number of places
+throughout the debugger.
+
+=head2 save
+
+save() saves the user's versions of globals that would mess us up in C<@saved>,
+and installs the versions we like better.
+
+=cut
+
sub save {
+ # Save eval failure, command failure, extended OS error, output field
+ # separator, input record separator, output record separator and
+ # the warning setting.
@saved = ($@, $!, $^E, $,, $/, $\, $^W);
- $, = ""; $/ = "\n"; $\ = ""; $^W = 0;
-}
+
+ $, = ""; # output field separator is null string
+ $/ = "\n"; # input record separator is newline
+ $\ = ""; # output record separator is null string
+ $^W = 0; # warnings are off
+} ## end sub save
+
+=head2 C<print_lineinfo> - show where we are now
+
+print_lineinfo prints whatever it is that it is handed; it prints it to the
+C<$LINEINFO> filehandle instead of just printing it to STDOUT. This allows
+us to feed line information to a slave editor without messing up the
+debugger output.
+
+=cut
sub print_lineinfo {
- resetterm(1) if $LINEINFO eq $OUT and $term_pid != $$;
- local $\ = '';
- local $, = '';
- print $LINEINFO @_;
-}
+ # Make the terminal sensible if we're not the primary debugger.
+ resetterm(1) if $LINEINFO eq $OUT and $term_pid != $$;
+ local $\ = '';
+ local $, = '';
+ print $LINEINFO @_;
+} ## end sub print_lineinfo
+
+=head2 C<postponed_sub>
+
+Handles setting postponed breakpoints in subroutines once they're compiled.
+For breakpoints, we use C<DB::find_sub> to locate the source file and line
+range for the subroutine, then mark the file as having a breakpoint,
+temporarily switch the C<*dbline> glob over to the source file, and then
+search the given range of lines to find a breakable line. If we find one,
+we set the breakpoint on it, deleting the breakpoint from C<%postponed>.
+
+=cut
# The following takes its argument via $evalarg to preserve current @_
sub postponed_sub {
- my $subname = shift;
- if ($postponed{$subname} =~ s/^break\s([+-]?\d+)\s+if\s//) {
- my $offset = $1 || 0;
- # Filename below can contain ':'
- my ($file,$i) = (find_sub($subname) =~ /^(.*):(\d+)-.*$/);
- if ($i) {
- $i += $offset;
- local *dbline = $main::{'_<' . $file};
- local $^W = 0; # != 0 is magical below
- $had_breakpoints{$file} |= 1;
- my $max = $#dbline;
- ++$i until $dbline[$i] != 0 or $i >= $max;
- $dbline{$i} = delete $postponed{$subname};
- } else {
- local $\ = '';
- print $OUT "Subroutine $subname not found.\n";
- }
- return;
- }
- elsif ($postponed{$subname} eq 'compile') { $signal = 1 }
- #print $OUT "In postponed_sub for `$subname'.\n";
-}
+ # Get the subroutine name.
+ my $subname = shift;
+
+ # If this is a 'break +<n> if <condition>' ...
+ if ($postponed{$subname} =~ s/^break\s([+-]?\d+)\s+if\s//) {
+ # If there's no offset, use '+0'.
+ my $offset = $1 || 0;
+
+ # find_sub's value is 'fullpath-filename:start-stop'. It's
+ # possible that the filename might have colons in it too.
+ my ($file, $i) = (find_sub($subname) =~ /^(.*):(\d+)-.*$/);
+ if ($i) {
+ # We got the start line. Add the offset '+<n>' from
+ # $postponed{subname}.
+ $i += $offset;
+
+ # Switch to the file this sub is in, temporarily.
+ local *dbline = $main::{ '_<' . $file };
+
+ # No warnings, please.
+ local $^W = 0; # != 0 is magical below
+
+ # This file's got a breakpoint in it.
+ $had_breakpoints{$file} |= 1;
+
+ # Last line in file.
+ my $max = $#dbline;
+
+ # Search forward until we hit a breakable line or get to
+ # the end of the file.
+ ++$i until $dbline[$i] != 0 or $i >= $max;
+
+ # Copy the breakpoint in and delete it from %postponed.
+ $dbline{$i} = delete $postponed{$subname};
+ } ## end if ($i)
+
+ # find_sub didn't find the sub.
+ else {
+ local $\ = '';
+ print $OUT "Subroutine $subname not found.\n";
+ }
+ return;
+ } ## end if ($postponed{$subname...
+ elsif ($postponed{$subname} eq 'compile') { $signal = 1 }
+
+ #print $OUT "In postponed_sub for `$subname'.\n";
+} ## end sub postponed_sub
+
+=head2 C<postponed>
+
+Called after each required file is compiled, but before it is executed;
+also called if the name of a just-compiled subroutine is a key of
+C<%postponed>. Propagates saved breakpoints (from C<b compile>, C<b load>,
+etc.) into the just-compiled code.
+
+If this is a C<require>'d file, the incoming parameter is the glob
+C<*{"_<$filename"}>, with C<$filename> the name of the C<require>'d file.
+
+If it's a subroutine, the incoming parameter is the subroutine name.
+
+=cut
sub postponed {
- if ($ImmediateStop) {
- $ImmediateStop = 0;
- $signal = 1;
- }
- return &postponed_sub
- unless ref \$_[0] eq 'GLOB'; # A subroutine is compiled.
- # Cannot be done before the file is compiled
- local *dbline = shift;
- my $filename = $dbline;
- $filename =~ s/^_<//;
- local $\ = '';
- $signal = 1, print $OUT "'$filename' loaded...\n"
- if $break_on_load{$filename};
- print_lineinfo(' ' x $stack_depth, "Package $filename.\n") if $frame;
- return unless $postponed_file{$filename};
- $had_breakpoints{$filename} |= 1;
- #%dbline = %{$postponed_file{$filename}}; # Cannot be done: unsufficient magic
- my $key;
- for $key (keys %{$postponed_file{$filename}}) {
- $dbline{$key} = ${$postponed_file{$filename}}{$key};
- }
- delete $postponed_file{$filename};
-}
+ # If there's a break, process it.
+ if ($ImmediateStop) {
+ # Right, we've stopped. Turn it off.
+ $ImmediateStop = 0;
+
+ # Enter the command loop when DB::DB gets called.
+ $signal = 1;
+ }
+
+ # If this is a subroutine, let postponed_sub() deal with it.
+ return &postponed_sub unless ref \$_[0] eq 'GLOB';
+
+ # Not a subroutine. Deal with the file.
+ local *dbline = shift;
+ my $filename = $dbline;
+ $filename =~ s/^_<//;
+ local $\ = '';
+ $signal = 1, print $OUT "'$filename' loaded...\n"
+ if $break_on_load{$filename};
+ print_lineinfo(' ' x $stack_depth, "Package $filename.\n") if $frame;
+
+ # Do we have any breakpoints to put in this file?
+ return unless $postponed_file{$filename};
+
+ # Yes. Mark this file as having breakpoints.
+ $had_breakpoints{$filename} |= 1;
+
+ # "Cannot be done: unsufficient magic" - we can't just put the
+ # breakpoints saved in %postponed_file into %dbline by assigning
+ # the whole hash; we have to do it one item at a time for the
+ # breakpoints to be set properly.
+ #%dbline = %{$postponed_file{$filename}};
+
+ # Set the breakpoints, one at a time.
+ my $key;
+
+ for $key (keys %{ $postponed_file{$filename} }) {
+ # Stash the saved breakpoint into the current file's magic line array.
+ $dbline{$key} = ${ $postponed_file{$filename} }{$key};
+ }
+
+ # This file's been compiled; discard the stored breakpoints.
+ delete $postponed_file{$filename};
+
+} ## end sub postponed
+
+=head2 C<dumpit>
+
+C<dumpit> is the debugger's wrapper around dumpvar.pl.
+
+It gets a filehandle (to which C<dumpvar.pl>'s output will be directed) and
+a reference to a variable (the thing to be dumped) as its input.
+
+The incoming filehandle is selected for output (C<dumpvar.pl> is printing to
+the currently-selected filehandle, thank you very much). The current
+values of the package globals C<$single> and C<$trace> are backed up in
+lexicals, and they are turned off (this keeps the debugger from trying
+to single-step through C<dumpvar.pl> (I think.)). C<$frame> is localized to
+preserve its current value and it is set to zero to prevent entry/exit
+messages from printing, and C<$doret> is localized as well and set to -2 to
+prevent return values from being shown.
+
+C<dumpit()> then checks to see if it needs to load C<dumpvar.pl> and
+tries to load it (note: if you have a C<dumpvar.pl> ahead of the
+installed version in @INC, yours will be used instead. Possible security
+problem?).
+
+It then checks to see if the subroutine C<main::dumpValue> is now defined
+(it should have been defined by C<dumpvar.pl>). If it has, C<dumpit()>
+localizes the globals necessary for things to be sane when C<main::dumpValue()>
+is called, and picks up the variable to be dumped from the parameter list.
+
+It checks the package global C<%options> to see if there's a C<dumpDepth>
+specified. If not, -1 is assumed; if so, the supplied value gets passed on to
+C<dumpvar.pl>. This tells C<dumpvar.pl> where to leave off when dumping a
+structure: -1 means dump everything.
+
+C<dumpValue()> is then called if possible; if not, C<dumpit()>just prints a
+warning.
+
+In either case, C<$single>, C<$trace>, C<$frame>, and C<$doret> are restored
+and we then return to the caller.
+
+=cut
sub dumpit {
+ # Save the current output filehandle and switch to the one
+ # passed in as the first parameter.
local ($savout) = select(shift);
+
+ # Save current settings of $single and $trace, and then turn them off.
my $osingle = $single;
- my $otrace = $trace;
+ my $otrace = $trace;
$single = $trace = 0;
+
+ # XXX Okay, what do $frame and $doret do, again?
local $frame = 0;
local $doret = -2;
+
+ # Load dumpvar.pl unless we've already got the sub we need from it.
unless (defined &main::dumpValue) {
- do 'dumpvar.pl';
+ do 'dumpvar.pl';
}
+
+ # If the load succeeded (or we already had dumpvalue()), go ahead
+ # and dump things.
if (defined &main::dumpValue) {
local $\ = '';
local $, = '';
local $" = ' ';
my $v = shift;
my $maxdepth = shift || $option{dumpDepth};
- $maxdepth = -1 unless defined $maxdepth; # -1 means infinite depth
- &main::dumpValue($v, $maxdepth);
- } else {
+ $maxdepth = -1 unless defined $maxdepth; # -1 means infinite depth
+ &main::dumpValue($v, $maxdepth);
+ } ## end if (defined &main::dumpValue)
+
+ # Oops, couldn't load dumpvar.pl.
+ else {
local $\ = '';
- print $OUT "dumpvar.pl not available.\n";
+ print $OUT "dumpvar.pl not available.\n";
}
+
+ # Reset $single and $trace to their old values.
$single = $osingle;
- $trace = $otrace;
- select ($savout);
-}
+ $trace = $otrace;
+
+ # Restore the old filehandle.
+ select($savout);
+} ## end sub dumpit
+
+=head2 C<print_trace>
+
+C<print_trace>'s job is to print a stack trace. It does this via the
+C<dump_trace> routine, which actually does all the ferreting-out of the
+stack trace data. C<print_trace> takes care of formatting it nicely and
+printing it to the proper filehandle.
+
+Parameters:
+
+=over 4
+
+=item * The filehandle to print to.
+
+=item * How many frames to skip before starting trace.
+
+=item * How many frames to print.
+
+=item * A flag: if true, print a "short" trace without filenames, line numbers, or arguments
+
+=back
+
+The original comment below seems to be noting that the traceback may not be
+correct if this routine is called in a tied method.
+
+=cut
# Tied method do not create a context, so may get wrong message:
sub print_trace {
- local $\ = '';
- my $fh = shift;
- resetterm(1) if $fh eq $LINEINFO and $LINEINFO eq $OUT and $term_pid != $$;
- my @sub = dump_trace($_[0] + 1, $_[1]);
- my $short = $_[2]; # Print short report, next one for sub name
- my $s;
- for ($i=0; $i <= $#sub; $i++) {
- last if $signal;
- local $" = ', ';
- my $args = defined $sub[$i]{args}
- ? "(@{ $sub[$i]{args} })"
- : '' ;
- $args = (substr $args, 0, $maxtrace - 3) . '...'
- if length $args > $maxtrace;
- my $file = $sub[$i]{file};
- $file = $file eq '-e' ? $file : "file `$file'" unless $short;
- $s = $sub[$i]{sub};
- $s = (substr $s, 0, $maxtrace - 3) . '...' if length $s > $maxtrace;
- if ($short) {
- my $sub = @_ >= 4 ? $_[3] : $s;
- print $fh "$sub[$i]{context}=$sub$args from $file:$sub[$i]{line}\n";
- } else {
- print $fh "$sub[$i]{context} = $s$args" .
- " called from $file" .
- " line $sub[$i]{line}\n";
- }
- }
-}
+ local $\ = '';
+ my $fh = shift;
+ # If this is going to a slave editor, but we're not the primary
+ # debugger, reset it first.
+ resetterm(1)
+ if $fh eq $LINEINFO # slave editor
+ and $LINEINFO eq $OUT # normal output
+ and $term_pid != $$; # not the primary
+
+ # Collect the actual trace information to be formatted.
+ # This is an array of hashes of subroutine call info.
+ my @sub = dump_trace($_[0] + 1, $_[1]);
+
+ # Grab the "short report" flag from @_.
+ my $short = $_[2]; # Print short report, next one for sub name
+
+ # Run through the traceback info, format it, and print it.
+ my $s;
+ for ($i = 0 ; $i <= $#sub ; $i++) {
+ # Drop out if the user has lost interest and hit control-C.
+ last if $signal;
+
+ # Set the separator so arrys print nice.
+ local $" = ', ';
+
+ # Grab and stringify the arguments if they are there.
+ my $args =
+ defined $sub[$i]{args}
+ ? "(@{ $sub[$i]{args} })"
+ : '';
+ # Shorten them up if $maxtrace says they're too long.
+ $args = (substr $args, 0, $maxtrace - 3) . '...'
+ if length $args > $maxtrace;
+
+ # Get the file name.
+ my $file = $sub[$i]{file};
+
+ # Put in a filename header if short is off.
+ $file = $file eq '-e' ? $file : "file `$file'" unless $short;
+
+ # Get the actual sub's name, and shorten to $maxtrace's requirement.
+ $s = $sub[$i]{sub};
+ $s = (substr $s, 0, $maxtrace - 3) . '...' if length $s > $maxtrace;
+
+ # Short report uses trimmed file and sub names.
+ if ($short) {
+ my $sub = @_ >= 4 ? $_[3] : $s;
+ print $fh
+ "$sub[$i]{context}=$sub$args from $file:$sub[$i]{line}\n";
+ } ## end if ($short)
+
+ # Non-short report includes full names.
+ else {
+ print $fh "$sub[$i]{context} = $s$args" . " called from $file" .
+ " line $sub[$i]{line}\n";
+ }
+ } ## end for ($i = 0 ; $i <= $#sub...
+} ## end sub print_trace
+
+=head2 dump_trace(skip[,count])
+
+Actually collect the traceback information available via C<caller()>. It does
+some filtering and cleanup of the data, but mostly it just collects it to
+make C<print_trace()>'s job easier.
+
+C<skip> defines the number of stack frames to be skipped, working backwards
+from the most current. C<count> determines the total number of frames to
+be returned; all of them (well, the first 10^9) are returned if C<count>
+is omitted.
+
+This routine returns a list of hashes, from most-recent to least-recent
+stack frame. Each has the following keys and values:
+
+=over 4
+
+=item * C<context> - C<.> (null), C<$> (scalar), or C<@> (array)
+
+=item * C<sub> - subroutine name, or C<eval> information
+
+=item * C<args> - undef, or a reference to an array of arguments
+
+=item * C<file> - the file in which this item was defined (if any)
+
+=item * C<line> - the line on which it was defined
+
+=back
+
+=cut
sub dump_trace {
- my $skip = shift;
- my $count = shift || 1e9;
- $skip++;
- $count += $skip;
- my ($p,$file,$line,$sub,$h,$args,$e,$r,@a,@sub,$context);
- my $nothard = not $frame & 8;
- local $frame = 0; # Do not want to trace this.
- my $otrace = $trace;
- $trace = 0;
- for ($i = $skip;
- $i < $count and ($p,$file,$line,$sub,$h,$context,$e,$r) = caller($i);
- $i++) {
- @a = ();
- for $arg (@args) {
- my $type;
- if (not defined $arg) {
- push @a, "undef";
- } elsif ($nothard and tied $arg) {
- push @a, "tied";
- } elsif ($nothard and $type = ref $arg) {
- push @a, "ref($type)";
- } else {
- local $_ = "$arg"; # Safe to stringify now - should not call f().
- s/([\'\\])/\\$1/g;
- s/(.*)/'$1'/s
- unless /^(?: -?[\d.]+ | \*[\w:]* )$/x;
- s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg;
- s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg;
- push(@a, $_);
- }
- }
- $context = $context ? '@' : (defined $context ? "\$" : '.');
- $args = $h ? [@a] : undef;
- $e =~ s/\n\s*\;\s*\Z// if $e;
- $e =~ s/([\\\'])/\\$1/g if $e;
- if ($r) {
- $sub = "require '$e'";
- } elsif (defined $r) {
- $sub = "eval '$e'";
- } elsif ($sub eq '(eval)') {
- $sub = "eval {...}";
- }
- push(@sub, {context => $context, sub => $sub, args => $args,
- file => $file, line => $line});
- last if $signal;
- }
- $trace = $otrace;
- @sub;
-}
+
+ # How many levels to skip.
+ my $skip = shift;
+
+ # How many levels to show. (1e9 is a cheap way of saying "all of them";
+ # it's unlikely that we'll have more than a billion stack frames. If you
+ # do, you've got an awfully big machine...)
+ my $count = shift || 1e9;
+
+ # We increment skip because caller(1) is the first level *back* from
+ # the current one. Add $skip to the count of frames so we have a
+ # simple stop criterion, counting from $skip to $count+$skip.
+ $skip++;
+ $count += $skip;
+
+ # These variables are used to capture output from caller();
+ my ($p, $file, $line, $sub, $h, $context);
+
+ my ($e, $r, @a, @sub, $args);
+
+ # XXX Okay... why'd we do that?
+ my $nothard = not $frame & 8;
+ local $frame = 0;
+
+ # Do not want to trace this.
+ my $otrace = $trace;
+ $trace = 0;
+
+ # Start out at the skip count.
+ # If we haven't reached the number of frames requested, and caller() is
+ # still returning something, stay in the loop. (If we pass the requested
+ # number of stack frames, or we run out - caller() returns nothing - we
+ # quit.
+ # Up the stack frame index to go back one more level each time.
+ for (
+ $i = $skip ;
+ $i < $count
+ and ($p, $file, $line, $sub, $h, $context, $e, $r) = caller($i) ;
+ $i++
+ )
+ {
+
+ # Go through the arguments and save them for later.
+ @a = ();
+ for $arg (@args) {
+ my $type;
+ if (not defined $arg) { # undefined parameter
+ push @a, "undef";
+ }
+
+ elsif ($nothard and tied $arg) { # tied parameter
+ push @a, "tied";
+ }
+ elsif ($nothard and $type = ref $arg) { # reference
+ push @a, "ref($type)";
+ }
+ else { # can be stringified
+ local $_ =
+ "$arg"; # Safe to stringify now - should not call f().
+
+ # Backslash any single-quotes or backslashes.
+ s/([\'\\])/\\$1/g;
+
+ # Single-quote it unless it's a number or a colon-separated
+ # name.
+ s/(.*)/'$1'/s
+ unless /^(?: -?[\d.]+ | \*[\w:]* )$/x;
+
+ # Turn high-bit characters into meta-whatever.
+ s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg;
+
+ # Turn control characters into ^-whatever.
+ s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg;
+
+ push (@a, $_);
+ } ## end else [ if (not defined $arg)
+ } ## end for $arg (@args)
+
+ # If context is true, this is array (@)context.
+ # If context is false, this is scalar ($) context.
+ # If neither, context isn't defined. (This is apparently a 'can't
+ # happen' trap.)
+ $context = $context ? '@' : (defined $context ? "\$" : '.');
+
+ # if the sub has args ($h true), make an anonymous array of the
+ # dumped args.
+ $args = $h ? [@a] : undef;
+
+ # remove trailing newline-whitespace-semicolon-end of line sequence
+ # from the eval text, if any.
+ $e =~ s/\n\s*\;\s*\Z// if $e;
+
+ # Escape backslashed single-quotes again if necessary.
+ $e =~ s/([\\\'])/\\$1/g if $e;
+
+ # if the require flag is true, the eval text is from a require.
+ if ($r) {
+ $sub = "require '$e'";
+ }
+ # if it's false, the eval text is really from an eval.
+ elsif (defined $r) {
+ $sub = "eval '$e'";
+ }
+
+ # If the sub is '(eval)', this is a block eval, meaning we don't
+ # know what the eval'ed text actually was.
+ elsif ($sub eq '(eval)') {
+ $sub = "eval {...}";
+ }
+
+ # Stick the collected information into @sub as an anonymous hash.
+ push (
+ @sub,
+ {
+ context => $context,
+ sub => $sub,
+ args => $args,
+ file => $file,
+ line => $line
+ }
+ );
+
+ # Stop processing frames if the user hit control-C.
+ last if $signal;
+ } ## end for ($i = $skip ; $i < ...
+
+ # Restore the trace value again.
+ $trace = $otrace;
+ @sub;
+} ## end sub dump_trace
+
+=head2 C<action()>
+
+C<action()> takes input provided as the argument to an add-action command,
+either pre- or post-, and makes sure it's a complete command. It doesn't do
+any fancy parsing; it just keeps reading input until it gets a string
+without a traiing backslash.
+
+=cut
sub action {
my $action = shift;
+
while ($action =~ s/\\$//) {
- #print $OUT "+ ";
- #$action .= "\n";
- $action .= &gets;
- }
+ # We have a backslash on the end. Read more.
+ $action .= &gets;
+ } ## end while ($action =~ s/\\$//)
+
+ # Return the assembled action.
$action;
-}
+} ## end sub action
+
+=head2 unbalanced
-sub unbalanced {
- # i hate using globals!
+This routine mostly just packages up a regular expression to be used
+to check that the thing it's being matched against has properly-matched
+curly braces.
+
+Of note is the definition of the $balanced_brace_re global via ||=, which
+speeds things up by only creating the qr//'ed expression once; if it's
+already defined, we don't try to define it again. A speed hack.
+
+=cut
+
+sub unbalanced {
+
+ # I hate using globals!
$balanced_brace_re ||= qr{
- ^ \{
- (?:
- (?> [^{}] + ) # Non-parens without backtracking
- |
- (??{ $balanced_brace_re }) # Group with matching parens
- ) *
- \} $
+ ^ \{
+ (?:
+ (?> [^{}] + ) # Non-parens without backtracking
+ |
+ (??{ $balanced_brace_re }) # Group with matching parens
+ ) *
+ \} $
}x;
- return $_[0] !~ m/$balanced_brace_re/;
-}
+ return $_[0] !~ m/$balanced_brace_re/;
+} ## end sub unbalanced
+
+=head2 C<gets()>
+
+C<gets()> is a primitive (very primitive) routine to read continuations.
+It was devised for reading continuations for actions.
+it just reads more input with X<C<readline()>> and returns it.
+
+=cut
sub gets {
&readline("cont: ");
}
+=head2 C<DB::system()> - handle calls to<system()> without messing up the debugger
+
+The C<system()> function assumes that it can just go ahead and use STDIN and
+STDOUT, but under the debugger, we want it to use the debugger's input and
+outout filehandles.
+
+C<DB::system()> socks away the program's STDIN and STDOUT, and then substitutes
+the debugger's IN and OUT filehandles for them. It does the C<system()> call,
+and then puts everything back again.
+
+=cut
+
sub system {
+
# We save, change, then restore STDIN and STDOUT to avoid fork() since
# some non-Unix systems can do system() but have problems with fork().
- open(SAVEIN,"<&STDIN") || &warn("Can't save STDIN");
- open(SAVEOUT,">&STDOUT") || &warn("Can't save STDOUT");
- open(STDIN,"<&IN") || &warn("Can't redirect STDIN");
- open(STDOUT,">&OUT") || &warn("Can't redirect STDOUT");
+ open(SAVEIN, "<&STDIN") || &warn("Can't save STDIN");
+ open(SAVEOUT, ">&STDOUT") || &warn("Can't save STDOUT");
+ open(STDIN, "<&IN") || &warn("Can't redirect STDIN");
+ open(STDOUT, ">&OUT") || &warn("Can't redirect STDOUT");
# XXX: using csh or tcsh destroys sigint retvals!
system(@_);
- open(STDIN,"<&SAVEIN") || &warn("Can't restore STDIN");
- open(STDOUT,">&SAVEOUT") || &warn("Can't restore STDOUT");
- close(SAVEIN);
+ open(STDIN, "<&SAVEIN") || &warn("Can't restore STDIN");
+ open(STDOUT, ">&SAVEOUT") || &warn("Can't restore STDOUT");
+ close(SAVEIN);
close(SAVEOUT);
-
# most of the $? crud was coping with broken cshisms
if ($? >> 8) {
- &warn("(Command exited ", ($? >> 8), ")\n");
- } elsif ($?) {
- &warn( "(Command died of SIG#", ($? & 127),
- (($? & 128) ? " -- core dumped" : "") , ")", "\n");
- }
+ &warn("(Command exited ", ($? >> 8), ")\n");
+ }
+ elsif ($?) {
+ &warn(
+ "(Command died of SIG#",
+ ($? & 127),
+ (($? & 128) ? " -- core dumped" : ""),
+ ")", "\n"
+ );
+ } ## end elsif ($?)
return $?;
-}
+} ## end sub system
+
+=head1 TTY MANAGEMENT
+
+The subs here do some of the terminal management for multiple debuggers.
+
+=head2 setterm
+
+Top-level function called when we want to set up a new terminal for use
+by the debugger.
+
+If the C<noTTY> debugger option was set, we'll either use the terminal
+supplied (the value of the C<noTTY> option), or we'll use C<Term::Rendezvous>
+to find one. If we're a forked debugger, we call C<resetterm> to try to
+get a whole new terminal if we can.
+
+In either case, we set up the terminal next. If the C<ReadLine> option was
+true, we'll get a C<Term::ReadLine> object for the current terminal and save
+the appropriate attributes. We then
+
+=cut
sub setterm {
+ # Load Term::Readline, but quietly; don't debug it and don't trace it.
local $frame = 0;
local $doret = -2;
eval { require Term::ReadLine } or die $@;
+
+ # If noTTY is set, but we have a TTY name, go ahead and hook up to it.
if ($notty) {
- if ($tty) {
- my ($i, $o) = split $tty, /,/;
- $o = $i unless defined $o;
- open(IN,"<$i") or die "Cannot open TTY `$i' for read: $!";
- open(OUT,">$o") or die "Cannot open TTY `$o' for write: $!";
- $IN = \*IN;
- $OUT = \*OUT;
- my $sel = select($OUT);
- $| = 1;
- select($sel);
- } else {
- eval "require Term::Rendezvous;" or die;
- my $rv = $ENV{PERLDB_NOTTY} || "/tmp/perldbtty$$";
- my $term_rv = new Term::Rendezvous $rv;
- $IN = $term_rv->IN;
- $OUT = $term_rv->OUT;
- }
- }
- if ($term_pid eq '-1') { # In a TTY with another debugger
- resetterm(2);
+ if ($tty) {
+ my ($i, $o) = split $tty, /,/;
+ $o = $i unless defined $o;
+ open(IN, "<$i") or die "Cannot open TTY `$i' for read: $!";
+ open(OUT, ">$o") or die "Cannot open TTY `$o' for write: $!";
+ $IN = \*IN;
+ $OUT = \*OUT;
+ my $sel = select($OUT);
+ $| = 1;
+ select($sel);
+ } ## end if ($tty)
+
+ # We don't have a TTY - try to find one via Term::Rendezvous.
+ else {
+ eval "require Term::Rendezvous;" or die;
+ # See if we have anything to pass to Term::Rendezvous.
+ # Use /tmp/perldbtty$$ if not.
+ my $rv = $ENV{PERLDB_NOTTY} || "/tmp/perldbtty$$";
+
+ # Rendezvous and get the filehandles.
+ my $term_rv = new Term::Rendezvous $rv;
+ $IN = $term_rv->IN;
+ $OUT = $term_rv->OUT;
+ } ## end else [ if ($tty)
+ } ## end if ($notty)
+
+
+ # We're a daughter debugger. Try to fork off another TTY.
+ if ($term_pid eq '-1') { # In a TTY with another debugger
+ resetterm(2);
}
+
+ # If we shouldn't use Term::ReadLine, don't.
if (!$rl) {
- $term = new Term::ReadLine::Stub 'perldb', $IN, $OUT;
- } else {
- $term = new Term::ReadLine 'perldb', $IN, $OUT;
-
- $rl_attribs = $term->Attribs;
- $rl_attribs->{basic_word_break_characters} .= '-:+/*,[])}'
- if defined $rl_attribs->{basic_word_break_characters}
- and index($rl_attribs->{basic_word_break_characters}, ":") == -1;
- $rl_attribs->{special_prefixes} = '$@&%';
- $rl_attribs->{completer_word_break_characters} .= '$@&%';
- $rl_attribs->{completion_function} = \&db_complete;
- }
- $LINEINFO = $OUT unless defined $LINEINFO;
+ $term = new Term::ReadLine::Stub 'perldb', $IN, $OUT;
+ }
+
+ # We're using Term::ReadLine. Get all the attributes for this terminal.
+ else {
+ $term = new Term::ReadLine 'perldb', $IN, $OUT;
+
+ $rl_attribs = $term->Attribs;
+ $rl_attribs->{basic_word_break_characters} .= '-:+/*,[])}'
+ if defined $rl_attribs->{basic_word_break_characters}
+ and index($rl_attribs->{basic_word_break_characters}, ":") == -1;
+ $rl_attribs->{special_prefixes} = '$@&%';
+ $rl_attribs->{completer_word_break_characters} .= '$@&%';
+ $rl_attribs->{completion_function} = \&db_complete;
+ } ## end else [ if (!$rl)
+
+ # Set up the LINEINFO filehandle.
+ $LINEINFO = $OUT unless defined $LINEINFO;
$lineinfo = $console unless defined $lineinfo;
+
$term->MinLine(2);
+
if ($term->Features->{setHistory} and "@hist" ne "?") {
- $term->SetHistory(@hist);
+ $term->SetHistory(@hist);
}
+
+ # XXX Ornaments are turned on unconditionally, which is not
+ # always a good thing.
ornaments($ornaments) if defined $ornaments;
$term_pid = $$;
-}
+} ## end sub setterm
+
+=head1 GET_FORK_TTY EXAMPLE FUNCTIONS
+
+When the process being debugged forks, or the process invokes a command
+via C<system()> which starts a new debugger, we need to be able to get a new
+C<IN> and C<OUT> filehandle for the new debugger. Otherwise, the two processes
+fight over the terminal, and you can never quite be sure who's going to get the
+input you're typing.
+
+C<get_fork_TTY> is a glob-aliased function which calls the real function that
+is tasked with doing all the necessary operating system mojo to get a new
+TTY (and probably another window) and to direct the new debugger to read and
+write there.
+
+The debugger provides C<get_fork_TTY> functions which work for X Windows and
+OS/2. Other systems are not supported. You are encouraged to write
+C<get_fork_TTY> functions which work for I<your> platform and contribute them.
+
+=head3 C<xterm_get_fork_TTY>
+
+This function provides the C<get_fork_TTY> function for X windows. If a
+program running under the debugger forks, a new <xterm> window is opened and
+the subsidiary debugger is directed there.
+
+The C<open()> call is of particular note here. We have the new C<xterm>
+we're spawning route file number 3 to STDOUT, and then execute the C<tty>
+command (which prints the device name of the TTY we'll want to use for input
+and output to STDOUT, then C<sleep> for a very long time, routing this output
+to file number 3. This way we can simply read from the <XT> filehandle (which
+is STDOUT from the I<commands> we ran) to get the TTY we want to use.
+
+Only works if C<xterm> is in your path and C<$ENV{DISPLAY}>, etc. are
+properly set up.
+
+=cut
-# Example get_fork_TTY functions
sub xterm_get_fork_TTY {
- (my $name = $0) =~ s,^.*[/\\],,s;
- open XT, qq[3>&1 xterm -title "Daughter Perl debugger $pids $name" -e sh -c 'tty 1>&3;\
+ (my $name = $0) =~ s,^.*[/\\],,s;
+ open XT,
+qq[3>&1 xterm -title "Daughter Perl debugger $pids $name" -e sh -c 'tty 1>&3;\
sleep 10000000' |];
- my $tty = <XT>;
- chomp $tty;
- $pidprompt = ''; # Shown anyway in titlebar
- return $tty;
-}
+
+ # Get the output from 'tty' and clean it up a little.
+ my $tty = <XT>;
+ chomp $tty;
+
+ $pidprompt = ''; # Shown anyway in titlebar
+
+ # There's our new TTY.
+ return $tty;
+} ## end sub xterm_get_fork_TTY
+
+=head3 C<os2_get_fork_TTY>
+
+XXX It behooves an OS/2 expert to write the necessary documentation for this!
+
+=cut
# This example function resets $IN, $OUT itself
sub os2_get_fork_TTY {
- local $^F = 40; # XXXX Fixme!
- local $\ = '';
- my ($in1, $out1, $in2, $out2);
- # Having -d in PERL5OPT would lead to a disaster...
- local $ENV{PERL5OPT} = $ENV{PERL5OPT} if $ENV{PERL5OPT};
- $ENV{PERL5OPT} =~ s/(?:^|(?<=\s))-d\b// if $ENV{PERL5OPT};
- $ENV{PERL5OPT} =~ s/(?:^|(?<=\s))-d\B/-/ if $ENV{PERL5OPT};
- print $OUT "Making kid PERL5OPT->`$ENV{PERL5OPT}'.\n" if $ENV{PERL5OPT};
- local $ENV{PERL5LIB} = $ENV{PERL5LIB} ? $ENV{PERL5LIB} : $ENV{PERLLIB};
- $ENV{PERL5LIB} = '' unless defined $ENV{PERL5LIB};
- $ENV{PERL5LIB} = join ';', @ini_INC, split /;/, $ENV{PERL5LIB};
- (my $name = $0) =~ s,^.*[/\\],,s;
- my @args;
- if ( pipe $in1, $out1 and pipe $in2, $out2
- # system P_SESSION will fail if there is another process
- # in the same session with a "dependent" asynchronous child session.
- and @args = ($rl, fileno $in1, fileno $out2,
- "Daughter Perl debugger $pids $name") and
- (($kpid = CORE::system 4, $^X, '-we', <<'ES', @args) >= 0 # P_SESSION
+ local $^F = 40; # XXXX Fixme!
+ local $\ = '';
+ my ($in1, $out1, $in2, $out2);
+
+ # Having -d in PERL5OPT would lead to a disaster...
+ local $ENV{PERL5OPT} = $ENV{PERL5OPT} if $ENV{PERL5OPT};
+ $ENV{PERL5OPT} =~ s/(?:^|(?<=\s))-d\b// if $ENV{PERL5OPT};
+ $ENV{PERL5OPT} =~ s/(?:^|(?<=\s))-d\B/-/ if $ENV{PERL5OPT};
+ print $OUT "Making kid PERL5OPT->`$ENV{PERL5OPT}'.\n" if $ENV{PERL5OPT};
+ local $ENV{PERL5LIB} = $ENV{PERL5LIB} ? $ENV{PERL5LIB} : $ENV{PERLLIB};
+ $ENV{PERL5LIB} = '' unless defined $ENV{PERL5LIB};
+ $ENV{PERL5LIB} = join ';', @ini_INC, split /;/, $ENV{PERL5LIB};
+ (my $name = $0) =~ s,^.*[/\\],,s;
+ my @args;
+
+ if (
+ pipe $in1, $out1
+ and pipe $in2, $out2
+
+ # system P_SESSION will fail if there is another process
+ # in the same session with a "dependent" asynchronous child session.
+ and @args = (
+ $rl, fileno $in1, fileno $out2,
+ "Daughter Perl debugger $pids $name"
+ )
+ and (
+ ($kpid = CORE::system 4, $^X, '-we',
+ <<'ES', @args) >= 0 # P_SESSION
END {sleep 5 unless $loaded}
BEGIN {open STDIN, '</dev/con' or warn "reopen stdin: $!"}
use OS2::Process;
-my ($rl, $in) = (shift, shift); # Read from $in and pass through
+my ($rl, $in) = (shift, shift); # Read from $in and pass through
set_title pop;
system P_NOWAIT, $^X, '-we', <<EOS or die "Cannot start a grandkid";
open IN, '<&=$in' or die "open <&=$in: \$!";
Term::ReadKey::ReadMode(4) if $rl; # Nodelay on kbd. Pipe is automatically nodelay...
print while sysread STDIN, $_, 1<<($rl ? 16 : 0);
ES
- or warn "system P_SESSION: $!, $^E" and 0)
- and close $in1 and close $out2 ) {
- $pidprompt = ''; # Shown anyway in titlebar
- reset_IN_OUT($in2, $out1);
- $tty = '*reset*';
- return ''; # Indicate that reset_IN_OUT is called
- }
- return;
-}
+ or warn "system P_SESSION: $!, $^E" and 0
+ )
+ and close $in1
+ and close $out2
+ )
+ {
+ $pidprompt = ''; # Shown anyway in titlebar
+ reset_IN_OUT($in2, $out1);
+ $tty = '*reset*';
+ return ''; # Indicate that reset_IN_OUT is called
+ } ## end if (pipe $in1, $out1 and...
+ return;
+} ## end sub os2_get_fork_TTY
+
+=head2 C<create_IN_OUT($flags)>
+
+Create a new pair of filehandles, pointing to a new TTY. If impossible,
+try to diagnose why.
+
+Flags are:
+
+=over 4
+
+=item * 1 - Don't know how to create a new TTY.
-sub create_IN_OUT { # Create a window with IN/OUT handles redirected there
+=item * 2 - Debugger has forked, but we can't get a new TTY.
+
+=item * 4 - standard debugger startup is happening.
+
+=back
+
+=cut
+
+sub create_IN_OUT { # Create a window with IN/OUT handles redirected there
+
+ # If we know how to get a new TTY, do it! $in will have
+ # the TTY name if get_fork_TTY works.
my $in = &get_fork_TTY if defined &get_fork_TTY;
- $in = $fork_TTY if defined $fork_TTY; # Backward compatibility
+
+ # It used to be that
+ $in = $fork_TTY if defined $fork_TTY; # Backward compatibility
+
if (not defined $in) {
- my $why = shift;
- print_help(<<EOP) if $why == 1;
+ my $why = shift;
+
+ # We don't know how.
+ print_help(<<EOP) if $why == 1;
I<#########> Forked, but do not know how to create a new B<TTY>. I<#########>
EOP
- print_help(<<EOP) if $why == 2;
+
+ # Forked debugger.
+ print_help(<<EOP) if $why == 2;
I<#########> Daughter session, do not know how to change a B<TTY>. I<#########>
This may be an asynchronous session, so the parent debugger may be active.
EOP
- print_help(<<EOP) if $why != 4;
+
+ # Note that both debuggers are fighting over the same input.
+ print_help(<<EOP) if $why != 4;
Since two debuggers fight for the same TTY, input is severely entangled.
EOP
- print_help(<<EOP);
+ print_help(<<EOP);
I know how to switch the output to a different window in xterms
and OS/2 consoles only. For a manual switch, put the name of the created I<TTY>
in B<\$DB::fork_TTY>, or define a function B<DB::get_fork_TTY()> returning this.
by typing B<tty>, and disconnect the I<shell> from I<TTY> by B<sleep 1000000>.
EOP
- } elsif ($in ne '') {
- TTY($in);
- } else {
- $console = ''; # Indicate no need to open-from-the-console
+ } ## end if (not defined $in)
+ elsif ($in ne '') {
+ TTY($in);
+ }
+ else {
+ $console = ''; # Indicate no need to open-from-the-console
}
undef $fork_TTY;
-}
+} ## end sub create_IN_OUT
+
+=head2 C<resetterm>
+
+Handles rejiggering the prompt when we've forked off a new debugger.
+
+If the new debugger happened because of a C<system()> that invoked a
+program under the debugger, the arrow between the old pid and the new
+in the prompt has I<two> dashes instead of one.
-sub resetterm { # We forked, so we need a different TTY
+We take the current list of pids and add this one to the end. If there
+isn't any list yet, we make one up out of the initial pid associated with
+the terminal and our new pid, sticking an arrow (either one-dashed or
+two dashed) in between them.
+
+If C<CreateTTY> is off, or C<resetterm> was called with no arguments,
+we don't try to create a new IN and OUT filehandle. Otherwise, we go ahead
+and try to do that.
+
+=cut
+
+sub resetterm { # We forked, so we need a different TTY
+
+ # Needs to be passed to create_IN_OUT() as well.
my $in = shift;
+
+ # resetterm(2): got in here because of a system() starting a debugger.
+ # resetterm(1): just forked.
my $systemed = $in > 1 ? '-' : '';
+
+ # If there's already a list of pids, add this to the end.
if ($pids) {
- $pids =~ s/\]/$systemed->$$]/;
- } else {
- $pids = "[$term_pid->$$]";
+ $pids =~ s/\]/$systemed->$$]/;
+ }
+
+ # No pid list. Time to make one.
+ else {
+ $pids = "[$term_pid->$$]";
}
+
+ # The prompt we're going to be using for this debugger.
$pidprompt = $pids;
- $term_pid = $$;
+
+ # We now 0wnz this terminal.
+ $term_pid = $$;
+
+ # Just return if we're not supposed to try to create a new TTY.
return unless $CreateTTY & $in;
+
+ # Try to create a new IN/OUT pair.
create_IN_OUT($in);
-}
+} ## end sub resetterm
+
+=head2 C<readline>
+
+First, we handle stuff in the typeahead buffer. If there is any, we shift off
+the next line, print a message saying we got it, add it to the terminal
+history (if possible), and return it.
+
+If there's nothing in the typeahead buffer, check the command filehandle stack.
+If there are any filehandles there, read from the last one, and return the line
+if we got one. If not, we pop the filehandle off and close it, and try the
+next one up the stack.
+
+If we've emptied the filehandle stack, we check to see if we've got a socket
+open, and we read that and return it if we do. If we don't, we just call the
+core C<readline()> and return its value.
+
+=cut
+
+sub readline {
+
+ # Localize to prevent it from being smashed in the program being debugged.
+ local $.;
+
+ # Pull a line out of the typeahead if there's stuff there.
+ if (@typeahead) {
+ # How many lines left.
+ my $left = @typeahead;
+
+ # Get the next line.
+ my $got = shift @typeahead;
+
+ # Print a message saying we got input from the typeahead.
+ local $\ = '';
+ print $OUT "auto(-$left)", shift, $got, "\n";
+
+ # Add it to the terminal history (if possible).
+ $term->AddHistory($got)
+ if length($got) > 1
+ and defined $term->Features->{addHistory};
+ return $got;
+ } ## end if (@typeahead)
+
+ # We really need to read some input. Turn off entry/exit trace and
+ # return value printing.
+ local $frame = 0;
+ local $doret = -2;
+
+ # If there are stacked filehandles to read from ...
+ while (@cmdfhs) {
+ # Read from the last one in the stack.
+ my $line = CORE::readline($cmdfhs[-1]);
+ # If we got a line ...
+ defined $line
+ ? (print $OUT ">> $line" and return $line) # Echo and return
+ : close pop @cmdfhs; # Pop and close
+ } ## end while (@cmdfhs)
+
+ # Nothing on the filehandle stack. Socket?
+ if (ref $OUT and UNIVERSAL::isa($OUT, 'IO::Socket::INET')) {
+ # Send anyting we have to send.
+ $OUT->write(join ('', @_));
+
+ # Receive anything there is to receive.
+ my $stuff;
+ $IN->recv($stuff, 2048); # XXX "what's wrong with sysread?"
+ # XXX Don't know. You tell me.
+
+ # What we got.
+ $stuff;
+ } ## end if (ref $OUT and UNIVERSAL::isa...
+
+ # No socket. Just read from the terminal.
+ else {
+ $term->readline(@_);
+ }
+} ## end sub readline
-sub readline {
- local $.;
- if (@typeahead) {
- my $left = @typeahead;
- my $got = shift @typeahead;
- local $\ = '';
- print $OUT "auto(-$left)", shift, $got, "\n";
- $term->AddHistory($got)
- if length($got) > 1 and defined $term->Features->{addHistory};
- return $got;
- }
- local $frame = 0;
- local $doret = -2;
- while (@cmdfhs) {
- my $line = CORE::readline($cmdfhs[-1]);
- defined $line ? (print $OUT ">> $line" and return $line)
- : close pop @cmdfhs;
- }
- if (ref $OUT and UNIVERSAL::isa($OUT, 'IO::Socket::INET')) {
- $OUT->write(join('', @_));
- my $stuff;
- $IN->recv( $stuff, 2048 ); # XXX: what's wrong with sysread?
- $stuff;
- }
- else {
- $term->readline(@_);
- }
-}
+=head1 OPTIONS SUPPORT ROUTINES
+
+These routines handle listing and setting option values.
+
+=head2 C<dump_option> - list the current value of an option setting
+
+This routine uses C<option_val> to look up the value for an option.
+It cleans up escaped single-quotes and then displays the option and
+its value.
+
+=cut
sub dump_option {
- my ($opt, $val)= @_;
- $val = option_val($opt,'N/A');
+ my ($opt, $val) = @_;
+ $val = option_val($opt, 'N/A');
$val =~ s/([\\\'])/\\$1/g;
printf $OUT "%20s = '%s'\n", $opt, $val;
-}
+} ## end sub dump_option
-sub options2remember {
- foreach my $k (@RememberOnROptions) {
- $option{$k}=option_val($k, 'N/A');
- }
- return %option;
-}
+=head2 C<option_val> - find the current value of an option
+
+This can't just be a simple hash lookup because of the indirect way that
+the option values are stored. Some are retrieved by calling a subroutine,
+some are just variables.
+
+You must supply a default value to be used in case the option isn't set.
+
+=cut
sub option_val {
- my ($opt, $default)= @_;
+ my ($opt, $default) = @_;
my $val;
- if (defined $optionVars{$opt}
- and defined ${$optionVars{$opt}}) {
- $val = ${$optionVars{$opt}};
- } elsif (defined $optionAction{$opt}
- and defined &{$optionAction{$opt}}) {
- $val = &{$optionAction{$opt}}();
- } elsif (defined $optionAction{$opt}
- and not defined $option{$opt}
- or defined $optionVars{$opt}
- and not defined ${$optionVars{$opt}}) {
- $val = $default;
- } else {
- $val = $option{$opt};
+
+ # Does this option exist, and is it a variable?
+ # If so, retrieve the value via the value in %optionVars.
+ if ( defined $optionVars{$opt}
+ and defined ${ $optionVars{$opt} }) {
+ $val = ${ $optionVars{$opt} };
+ }
+
+ # Does this option exist, and it's a subroutine?
+ # If so, call the subroutine via the ref in %optionAction
+ # and capture the value.
+ elsif ( defined $optionAction{$opt}
+ and defined &{ $optionAction{$opt} }) {
+ $val = &{ $optionAction{$opt} }();
+ }
+
+ # If there's an action or variable for the supplied option,
+ # but no value was set, use the default.
+ elsif (defined $optionAction{$opt} and not defined $option{$opt}
+ or defined $optionVars{$opt} and not defined ${ $optionVars{$opt} })
+ {
+ $val = $default;
}
+
+ # Otherwise, do the simple hash lookup.
+ else {
+ $val = $option{$opt};
+ }
+
+ # If the value isn't defined, use the default.
+ # Then return whatever the value is.
$val = $default unless defined $val;
- $val
-}
+ $val;
+} ## end sub option_val
+
+=head2 C<parse_options>
+
+Handles the parsing and execution of option setting/displaying commands.
+
+An option entered by itself is assumed to be 'set me to 1' (the default value)
+if the option is a boolean one. If not, the user is prompted to enter a valid
+value or to query the current value (via 'option? ').
+
+If 'option=value' is entered, we try to extract a quoted string from the
+value (if it is quoted). If it's not, we just use the whole value as-is.
+
+We load any modules required to service this option, and then we set it: if
+it just gets stuck in a variable, we do that; if there's a subroutine to
+handle setting the option, we call that.
+
+Finally, if we're running in interactive mode, we display the effect of the
+user's command back to the terminal, skipping this if we're setting things
+during initialization.
+
+=cut
sub parse_options {
- local($_)= @_;
+ local ($_) = @_;
local $\ = '';
- # too dangerous to let intuitive usage overwrite important things
- # defaultion should never be the default
- my %opt_needs_val = map { ( $_ => 1 ) } qw{
- dumpDepth arrayDepth hashDepth LineInfo maxTraceLen ornaments windowSize
- pager quote ReadLine recallCommand RemotePort ShellBang TTY
- };
+
+ # These options need a value. Don't allow them to be clobbered by accident.
+ my %opt_needs_val = map { ($_ => 1) } qw{
+ dumpDepth arrayDepth hashDepth LineInfo maxTraceLen ornaments windowSize
+ pager quote ReadLine recallCommand RemotePort ShellBang TTY
+ };
+
while (length) {
- my $val_defaulted;
- s/^\s+// && next;
- s/^(\w+)(\W?)// or print($OUT "Invalid option `$_'\n"), last;
- my ($opt,$sep) = ($1,$2);
- my $val;
- if ("?" eq $sep) {
- print($OUT "Option query `$opt?' followed by non-space `$_'\n"), last
- if /^\S/;
- #&dump_option($opt);
- } elsif ($sep !~ /\S/) {
- $val_defaulted = 1;
- $val = "1"; # this is an evil default; make 'em set it!
- } elsif ($sep eq "=") {
- if (s/ (["']) ( (?: \\. | (?! \1 ) [^\\] )* ) \1 //x) {
+ my $val_defaulted;
+
+ # Clean off excess leading whitespace.
+ s/^\s+// && next;
+
+ # Options are always all word characters, followed by a non-word
+ # separator.
+ s/^(\w+)(\W?)// or print($OUT "Invalid option `$_'\n"), last;
+ my ($opt, $sep) = ($1, $2);
+
+ my $val;
+
+ # '?' as separator means query, but must have whitespace after it.
+ if ("?" eq $sep) {
+ print($OUT "Option query `$opt?' followed by non-space `$_'\n"),
+ last
+ if /^\S/;
+
+ #&dump_option($opt);
+ } ## end if ("?" eq $sep)
+
+ # Separator is whitespace (or just a carriage return).
+ # They're going for a default, which we assume is 1.
+ elsif ($sep !~ /\S/) {
+ $val_defaulted = 1;
+ $val = "1"; # this is an evil default; make 'em set it!
+ }
+
+ # Separator is =. Trying to set a value.
+ elsif ($sep eq "=") {
+ # If quoted, extract a quoted string.
+ if (s/ (["']) ( (?: \\. | (?! \1 ) [^\\] )* ) \1 //x) {
my $quote = $1;
($val = $2) =~ s/\\([$quote\\])/$1/g;
- } else {
- s/^(\S*)//;
- $val = $1;
- print OUT qq(Option better cleared using $opt=""\n)
- unless length $val;
- }
-
- } else { #{ to "let some poor schmuck bounce on the % key in B<vi>."
- my ($end) = "\\" . substr( ")]>}$sep", index("([<{",$sep), 1 ); #}
- s/^(([^\\$end]|\\[\\$end])*)$end($|\s+)// or
- print($OUT "Unclosed option value `$opt$sep$_'\n"), last;
- ($val = $1) =~ s/\\([\\$end])/$1/g;
- }
-
- my $option;
- my $matches = grep( /^\Q$opt/ && ($option = $_), @options )
- || grep( /^\Q$opt/i && ($option = $_), @options );
-
- print($OUT "Unknown option `$opt'\n"), next unless $matches;
- print($OUT "Ambiguous option `$opt'\n"), next if $matches > 1;
-
- if ($opt_needs_val{$option} && $val_defaulted) {
- my $cmd = ($CommandSet eq '580') ? 'o' : 'O';
- print $OUT "Option `$opt' is non-boolean. Use `$cmd $option=VAL' to set, `$cmd $option?' to query\n";
- next;
- }
-
- $option{$option} = $val if defined $val;
-
- eval qq{
- local \$frame = 0;
- local \$doret = -2;
- require '$optionRequire{$option}';
- 1;
- } || die # XXX: shouldn't happen
- if defined $optionRequire{$option} &&
- defined $val;
-
- ${$optionVars{$option}} = $val
- if defined $optionVars{$option} &&
- defined $val;
-
- &{$optionAction{$option}} ($val)
- if defined $optionAction{$option} &&
- defined &{$optionAction{$option}} &&
- defined $val;
-
- # Not $rcfile
- dump_option($option) unless $OUT eq \*STDERR;
- }
-}
+ }
+
+ # Not quoted. Use the whole thing. Warn about 'option='.
+ # XXX Spurious messages about clearing nonexistent options
+ # XXX can be created, e.g., 'o googleWhack='.
+ else {
+ s/^(\S*)//;
+ $val = $1;
+ print OUT qq(Option better cleared using $opt=""\n)
+ unless length $val;
+ } ## end else [ if (s/ (["']) ( (?: \\. | (?! \1 ) [^\\] )* ) \1 //x)
+
+ } ## end elsif ($sep eq "=")
+
+ # "Quoted" with [], <>, or {}.
+ else { #{ to "let some poor schmuck bounce on the % key in B<vi>."
+ my ($end) = "\\" . substr(")]>}$sep", index("([<{", $sep), 1); #}
+ s/^(([^\\$end]|\\[\\$end])*)$end($|\s+)//
+ or print($OUT "Unclosed option value `$opt$sep$_'\n"), last;
+ ($val = $1) =~ s/\\([\\$end])/$1/g;
+ } ## end else [ if ("?" eq $sep)
+
+ my $option;
+
+ # Make sure that such an option exists.
+ my $matches = grep(/^\Q$opt/ && ($option = $_), @options) ||
+ grep(/^\Q$opt/i && ($option = $_), @options);
+
+ print($OUT "Unknown option `$opt'\n"), next unless $matches;
+ print($OUT "Ambiguous option `$opt'\n"), next if $matches > 1;
+
+ # Exclude non-booleans from getting set to 1 by default.
+ if ($opt_needs_val{$option} && $val_defaulted) {
+ my $cmd = ($CommandSet eq '580') ? 'o' : 'O';
+ print $OUT
+"Option `$opt' is non-boolean. Use `$cmd $option=VAL' to set, `$cmd $option?' to query\n";
+ next;
+ } ## end if ($opt_needs_val{$option...
+
+ # Save the option value.
+ $option{$option} = $val if defined $val;
+
+ # Load any module that this option requires.
+ eval qq{
+ local \$frame = 0;
+ local \$doret = -2;
+ require '$optionRequire{$option}';
+ 1;
+ } || die # XXX: shouldn't happen
+ if defined $optionRequire{$option} &&
+ defined $val;
+
+ # Set it.
+ # Stick it in the proper variable if it goes in a variable.
+ ${ $optionVars{$option} } = $val
+ if defined $optionVars{$option} &&
+ defined $val;
+
+ # Call the appropriate sub if it gets set via sub.
+ &{ $optionAction{$option} }($val)
+ if defined $optionAction{$option} &&
+ defined &{ $optionAction{$option} } &&
+ defined $val;
+
+ # Not initialization - echo the value we set it to.
+ dump_option($option) unless $OUT eq \*STDERR;
+ } ## end while (length)
+} ## end sub parse_options
+
+=head1 RESTART SUPPORT
+
+These routines are used to store (and restore) lists of items in environment
+variables during a restart.
+
+=head2 set_list
+
+Set_list packages up items to be stored in a set of environment variables
+(VAR_n, containing the number of items, and VAR_0, VAR_1, etc., containing
+the values). Values outside the standard ASCII charset are stored by encoding
+then as hexadecimal values.
+
+=cut
sub set_list {
- my ($stem,@list) = @_;
- my $val;
- $ENV{"${stem}_n"} = @list;
- for $i (0 .. $#list) {
- $val = $list[$i];
- $val =~ s/\\/\\\\/g;
- $val =~ s/([\0-\37\177\200-\377])/"\\0x" . unpack('H2',$1)/eg;
- $ENV{"${stem}_$i"} = $val;
- }
-}
+ my ($stem, @list) = @_;
+ my $val;
+
+ # VAR_n: how many we have. Scalar assignment gets the number of items.
+ $ENV{"${stem}_n"} = @list;
+
+ # Grab each item in the list, escape the backslashes, encode the non-ASCII
+ # as hex, and then save in the appropriate VAR_0, VAR_1, etc.
+ for $i (0 .. $#list) {
+ $val = $list[$i];
+ $val =~ s/\\/\\\\/g;
+ $val =~ s/([\0-\37\177\200-\377])/"\\0x" . unpack('H2',$1)/eg;
+ $ENV{"${stem}_$i"} = $val;
+ } ## end for $i (0 .. $#list)
+} ## end sub set_list
+
+=head2 get_list
+
+Reverse the set_list operation: grab VAR_n to see how many we should be getting
+back, and then pull VAR_0, VAR_1. etc. back out.
+
+=cut
sub get_list {
- my $stem = shift;
- my @list;
- my $n = delete $ENV{"${stem}_n"};
- my $val;
- for $i (0 .. $n - 1) {
- $val = delete $ENV{"${stem}_$i"};
- $val =~ s/\\((\\)|0x(..))/ $2 ? $2 : pack('H2', $3) /ge;
- push @list, $val;
- }
- @list;
-}
+ my $stem = shift;
+ my @list;
+ my $n = delete $ENV{"${stem}_n"};
+ my $val;
+ for $i (0 .. $n - 1) {
+ $val = delete $ENV{"${stem}_$i"};
+ $val =~ s/\\((\\)|0x(..))/ $2 ? $2 : pack('H2', $3) /ge;
+ push @list, $val;
+ }
+ @list;
+} ## end sub get_list
+
+=head1 MISCELLANEOUS SIGNAL AND I/O MANAGEMENT
+
+=head2 catch()
+
+The C<catch()> subroutine is the essence of fast and low-impact. We simply
+set an already-existing global scalar variable to a constant value. This
+avoids allocating any memory possibly in the middle of something that will
+get all confused if we do.
+
+=cut
sub catch {
$signal = 1;
- return; # Put nothing on the stack - malloc/free land!
+ return; # Put nothing on the stack - malloc/free land!
}
+=head2 C<warn()>
+
+C<warn> emits a warning, by joining together its arguments and printing
+them, with couple of fillips.
+
+If the composited message I<doesn't> end with a newline, we automatically
+add C<$!> and a newline to the end of the message. The subroutine expects $OUT
+to be set to the filehandle to be used to output warnings; it makes no
+assumptions about what filehandles are available.
+
+=cut
+
sub warn {
- my($msg)= join("",@_);
+ my ($msg) = join ("", @_);
$msg .= ": $!\n" unless $msg =~ /\n$/;
local $\ = '';
print $OUT $msg;
-}
+} ## end sub warn
+
+=head1 INITIALIZATION TTY SUPPORT
+
+=head2 C<reset_IN_OUT>
+
+This routine handles restoring the debugger's input and output filehandles
+after we've tried and failed to move them elsewhere. In addition, it assigns
+the debugger's output filehandle to $LINEINFO if it was already open there.
+
+=cut
sub reset_IN_OUT {
my $switch_li = $LINEINFO eq $OUT;
+
+ # If there's a term and it's able to get a new tty, try to get one.
if ($term and $term->Features->{newTTY}) {
- ($IN, $OUT) = (shift, shift);
- $term->newTTY($IN, $OUT);
- } elsif ($term) {
- &warn("Too late to set IN/OUT filehandles, enabled on next `R'!\n");
- } else {
- ($IN, $OUT) = (shift, shift);
+ ($IN, $OUT) = (shift, shift);
+ $term->newTTY($IN, $OUT);
+ }
+
+ # This term can't get a new tty now. Better luck later.
+ elsif ($term) {
+ &warn("Too late to set IN/OUT filehandles, enabled on next `R'!\n");
+ }
+
+ # Set the filehndles up as they were.
+ else {
+ ($IN, $OUT) = (shift, shift);
}
+
+ # Unbuffer the output filehandle.
my $o = select $OUT;
$| = 1;
select $o;
+
+ # Point LINEINFO to the same output filehandle if it was there before.
$LINEINFO = $OUT if $switch_li;
-}
+} ## end sub reset_IN_OUT
+
+=head1 OPTION SUPPORT ROUTINES
+
+The following routines are used to process some of the more complicated
+debugger options.
+
+=head2 C<TTY>
+
+Sets the input and output filehandles to the specified files or pipes.
+If the terminal supports switching, we go ahead and do it. If not, and
+there's already a terminal in place, we save the infomation to take effect
+on restart.
+
+If there's no terminal yet (for instance, during debugger initialization),
+we go ahead and set C<$console> and C<$tty> to the file indicated.
+
+=cut
sub TTY {
if (@_ and $term and $term->Features->{newTTY}) {
- my ($in, $out) = shift;
- if ($in =~ /,/) {
- ($in, $out) = split /,/, $in, 2;
- } else {
- $out = $in;
- }
- open IN, $in or die "cannot open `$in' for read: $!";
- open OUT, ">$out" or die "cannot open `$out' for write: $!";
- reset_IN_OUT(\*IN,\*OUT);
- return $tty = $in;
- }
+ # This terminal supports switching to a new TTY.
+ # Can be a list of two files, or on string containing both names,
+ # comma-separated.
+ # XXX Should this perhaps be an assignment from @_?
+ my ($in, $out) = shift;
+ if ($in =~ /,/) {
+ # Split list apart if supplied.
+ ($in, $out) = split /,/, $in, 2;
+ }
+ else {
+ # Use the same file for both input and output.
+ $out = $in;
+ }
+
+ # Open file onto the debugger's filehandles, if you can.
+ open IN, $in or die "cannot open `$in' for read: $!";
+ open OUT, ">$out" or die "cannot open `$out' for write: $!";
+
+ # Swap to the new filehandles.
+ reset_IN_OUT(\*IN, \*OUT);
+
+ # Save the setting for later.
+ return $tty = $in;
+ } ## end if (@_ and $term and $term...
+
+ # Terminal doesn't support new TTY, or doesn't support readline.
+ # Can't do it now, try restarting.
&warn("Too late to set TTY, enabled on next `R'!\n") if $term and @_;
+
# Useful if done through PERLDB_OPTS:
$console = $tty = shift if @_;
+
+ # Return whatever the TTY is.
$tty or $console;
-}
+} ## end sub TTY
+
+=head2 C<noTTY>
+
+Sets the C<$notty> global, controlling whether or not the debugger tries to
+get a terminal to read from. If called after a terminal is already in place,
+we save the value to use it if we're restarted.
+
+=cut
sub noTTY {
if ($term) {
- &warn("Too late to set noTTY, enabled on next `R'!\n") if @_;
+ &warn("Too late to set noTTY, enabled on next `R'!\n") if @_;
}
$notty = shift if @_;
$notty;
-}
+} ## end sub noTTY
+
+=head2 C<ReadLine>
+
+Sets the C<$rl> option variable. If 0, we use C<Term::ReadLine::Stub>
+(essentially, no C<readline> processing on this "terminal"). Otherwise, we
+use C<Term::ReadLine>. Can't be changed after a terminal's in place; we save
+the value in case a restart is done so we can change it then.
+
+=cut
sub ReadLine {
if ($term) {
- &warn("Too late to set ReadLine, enabled on next `R'!\n") if @_;
+ &warn("Too late to set ReadLine, enabled on next `R'!\n") if @_;
}
$rl = shift if @_;
$rl;
-}
+} ## end sub ReadLine
+
+=head2 C<RemotePort>
+
+Sets the port that the debugger will try to connect to when starting up.
+If the terminal's already been set up, we can't do it, but we remember the
+setting in case the user does a restart.
+
+=cut
sub RemotePort {
if ($term) {
}
$remoteport = shift if @_;
$remoteport;
-}
+} ## end sub RemotePort
+
+=head2 C<tkRunning>
+
+Checks with the terminal to see if C<Tk> is running, and returns true or
+false. Returns false if the current terminal doesn't support C<readline>.
+
+=cut
sub tkRunning {
- if (${$term->Features}{tkRunning}) {
+ if (${ $term->Features }{tkRunning}) {
return $term->tkRunning(@_);
- } else {
- local $\ = '';
- print $OUT "tkRunning not supported by current ReadLine package.\n";
- 0;
}
-}
+ else {
+ local $\ = '';
+ print $OUT "tkRunning not supported by current ReadLine package.\n";
+ 0;
+ }
+} ## end sub tkRunning
+
+=head2 C<NonStop>
+
+Sets nonstop mode. If a terminal's already been set up, it's too late; the
+debugger remembers the setting in case you restart, though.
+
+=cut
sub NonStop {
if ($term) {
- &warn("Too late to set up NonStop mode, enabled on next `R'!\n") if @_;
+ &warn("Too late to set up NonStop mode, enabled on next `R'!\n")
+ if @_;
}
$runnonstop = shift if @_;
$runnonstop;
-}
+} ## end sub NonStop
-sub DollarCaretP {
- if ($term) {
- &warn("Some flag changes could not take effect until next 'R'!\n") if @_;
- }
- $^P = parse_DollarCaretP_flags(shift) if @_;
- expand_DollarCaretP_flags($^P)
-}
+=head2 C<pager>
-sub OnlyAssertions {
- if ($term) {
- &warn("Too late to set up OnlyAssertions mode, enabled on next 'R'!\n") if @_;
- }
- if (@_) {
- unless (defined $ini_assertion) {
- if ($term) {
- &warn("Current Perl interpreter doesn't support assertions");
- }
- return 0;
- }
- if (shift) {
- unless ($ini_assertion) {
- print "Assertions will be active on next 'R'!\n";
- $ini_assertion=1;
- }
- $^P&= ~$DollarCaretP_flags{PERLDBf_SUB};
- $^P|=$DollarCaretP_flags{PERLDBf_ASSERTION};
- }
- else {
- $^P|=$DollarCaretP_flags{PERLDBf_SUB};
- }
- }
- !($^P & $DollarCaretP_flags{PERLDBf_SUB}) || 0;
-}
+Set up the C<$pager> variable. Adds a pipe to the front unless there's one
+there already.
+
+=cut
sub pager {
if (@_) {
- $pager = shift;
- $pager="|".$pager unless $pager =~ /^(\+?\>|\|)/;
+ $pager = shift;
+ $pager = "|" . $pager unless $pager =~ /^(\+?\>|\|)/;
}
$pager;
-}
+} ## end sub pager
+
+=head2 C<shellBang>
+
+Sets the shell escape command, and generates a printable copy to be used
+in the help.
+
+=cut
sub shellBang {
+
+ # If we got an argument, meta-quote it, and add '\b' if it
+ # ends in a word character.
if (@_) {
- $sh = quotemeta shift;
- $sh .= "\\b" if $sh =~ /\w$/;
+ $sh = quotemeta shift;
+ $sh .= "\\b" if $sh =~ /\w$/;
}
- $psh = $sh;
- $psh =~ s/\\b$//;
- $psh =~ s/\\(.)/$1/g;
- $psh;
-}
+
+ # Generate the printable version for the help:
+ $psh = $sh; # copy it
+ $psh =~ s/\\b$//; # Take off trailing \b if any
+ $psh =~ s/\\(.)/$1/g; # De-escape
+ $psh; # return the printable version
+} ## end sub shellBang
+
+=head2 C<ornaments>
+
+If the terminal has its own ornaments, fetch them. Otherwise accept whatever
+was passed as the argument. (This means you can't override the terminal's
+ornaments.)
+
+=cut
sub ornaments {
- if (defined $term) {
- local ($warnLevel,$dieLevel) = (0, 1);
- return '' unless $term->Features->{ornaments};
- eval { $term->ornaments(@_) } || '';
- } else {
- $ornaments = shift;
- }
-}
+ if (defined $term) {
+ # We don't want to show warning backtraces, but we do want die() ones.
+ local ($warnLevel, $dieLevel) = (0, 1);
+
+ # No ornaments if the terminal doesn't support them.
+ return '' unless $term->Features->{ornaments};
+ eval { $term->ornaments(@_) } || '';
+ }
+
+ # Use what was passed in if we can't determine it ourselves.
+ else {
+ $ornaments = shift;
+ }
+} ## end sub ornaments
+
+=head2 C<recallCommand>
+
+Sets the recall command, and builds a printable version which will appear in
+the help text.
+
+=cut
sub recallCommand {
+
+ # If there is input, metaquote it. Add '\b' if it ends with a word
+ # character.
if (@_) {
- $rc = quotemeta shift;
- $rc .= "\\b" if $rc =~ /\w$/;
+ $rc = quotemeta shift;
+ $rc .= "\\b" if $rc =~ /\w$/;
}
- $prc = $rc;
- $prc =~ s/\\b$//;
- $prc =~ s/\\(.)/$1/g;
- $prc;
-}
+
+ # Build it into a printable version.
+ $prc = $rc; # Copy it
+ $prc =~ s/\\b$//; # Remove trailing \b
+ $prc =~ s/\\(.)/$1/g; # Remove escapes
+ $prc; # Return the printable version
+} ## end sub recallCommand
+
+=head2 C<LineInfo> - where the line number information goes
+
+Called with no arguments, returns the file or pipe that line info should go to.
+
+Called with an argument (a file or a pipe), it opens that onto the
+C<LINEINFO> filehandle, unbuffers the filehandle, and then returns the
+file or pipe again to the caller.
+
+=cut
sub LineInfo {
return $lineinfo unless @_;
$lineinfo = shift;
+
+ # If this is a valid "thing to be opened for output", tack a
+ # '>' onto the front.
my $stream = ($lineinfo =~ /^(\+?\>|\|)/) ? $lineinfo : ">$lineinfo";
+
+ # If this is a pipe, the stream points to a slave editor.
$slave_editor = ($stream =~ /^\|/);
+
+ # Open it up and unbuffer it.
open(LINEINFO, "$stream") || &warn("Cannot open `$stream' for write");
$LINEINFO = \*LINEINFO;
my $save = select($LINEINFO);
$| = 1;
select($save);
+
+ # Hand the file or pipe back again.
$lineinfo;
-}
+} ## end sub LineInfo
-sub list_modules { # versions
- my %version;
- my $file;
- for (keys %INC) {
- $file = $_;
- s,\.p[lm]$,,i ;
- s,/,::,g ;
- s/^perl5db$/DB/;
- s/^Term::ReadLine::readline$/readline/;
- if (defined ${ $_ . '::VERSION' }) {
- $version{$file} = "${ $_ . '::VERSION' } from ";
- }
- $version{$file} .= $INC{$file};
- }
- dumpit($OUT,\%version);
-}
+=head1 COMMAND SUPPORT ROUTINES
+
+These subroutines provide functionality for various commands.
+
+=head2 C<list_modules>
+
+For the C<M> command: list modules loaded and their versions.
+Essentially just runs through the keys in %INC, picks up the
+$VERSION package globals from each package, gets the file name, and formats the
+information for output.
+
+=cut
+
+sub list_modules { # versions
+ my %version;
+ my $file;
+ # keys are the "as-loaded" name, values are the fully-qualified path
+ # to the file itself.
+ for (keys %INC) {
+ $file = $_; # get the module name
+ s,\.p[lm]$,,i; # remove '.pl' or '.pm'
+ s,/,::,g; # change '/' to '::'
+ s/^perl5db$/DB/; # Special case: debugger
+ # moves to package DB
+ s/^Term::ReadLine::readline$/readline/; # simplify readline
+
+ # If the package has a $VERSION package global (as all good packages
+ # should!) decode it and save as partial message.
+ if (defined ${ $_ . '::VERSION' }) {
+ $version{$file} = "${ $_ . '::VERSION' } from ";
+ }
+
+ # Finish up the message with the file the package came from.
+ $version{$file} .= $INC{$file};
+ } ## end for (keys %INC)
+
+ # Hey, dumpit() formats a hash nicely, so why not use it?
+ dumpit($OUT, \%version);
+} ## end sub list_modules
+
+=head2 C<sethelp()>
+
+Sets up the monster string used to format and print the help.
+
+=head3 HELP MESSAGE FORMAT
+
+The help message is a peculiar format unto itself; it mixes C<pod> 'ornaments'
+(BE<lt>E<gt>, IE<gt>E<lt>) with tabs to come up with a format that's fairly
+easy to parse and portable, but which still allows the help to be a little
+nicer than just plain text.
+
+Essentially, you define the command name (usually marked up with BE<gt>E<lt>
+and IE<gt>E<lt>), followed by a tab, and then the descriptive text, ending in a newline. The descriptive text can also be marked up in the same way. If you
+need to continue the descriptive text to another line, start that line with
+just tabs and then enter the marked-up text.
+
+If you are modifying the help text, I<be careful>. The help-string parser is
+not very sophisticated, and if you don't follow these rules it will mangle the
+help beyond hope until you fix the string.
+
+=cut
sub sethelp {
+
# XXX: make sure there are tabs between the command and explanation,
# or print_help will screw up your formatting if you have
# eeevil ornaments enabled. This is an insane mess.
$help = "
-Help is currently only available for the new 580 CommandSet,
-if you really want old behaviour, presumably you know what
-you're doing ?-)
+Help is currently only available for the new 5.8 command set.
+No help is available for the old command set.
+We assume you know what you're doing if you switch to it.
B<T> Stack trace.
B<s> [I<expr>] Single step [in I<expr>].
B<V> [I<pkg> [I<vars>]] List some (default all) variables in package (default current).
Use B<~>I<pattern> and B<!>I<pattern> for positive and negative regexps.
B<X> [I<vars>] Same as \"B<V> I<currentpackage> [I<vars>]\".
-B<y> [I<n> [I<Vars>]] List lexicals in higher scope <n>. Vars same as B<V>.
B<x> I<expr> Evals expression in list context, dumps the result.
B<m> I<expr> Evals expression in list context, prints methods callable
on the first element of the result.
B<m> I<class> Prints methods callable via the given class.
B<M> Show versions of loaded modules.
-B<y> [I<n> [I<vars>]] List lexical variables I<n> levels up from current sub
+B<y> [I<n> [I<Vars>]] List lexicals in higher scope <n>. Vars same as B<V>.
B<<> ? List Perl commands to run before each prompt.
B<<> I<expr> Define Perl command to run before each prompt.
B<<<> I<expr> Add to the list of Perl commands to run before each prompt.
-B<< *> Delete the list of perl commands to run before each prompt.
+B<< *> Delete the list of perl commands to run before each prompt.
B<>> ? List Perl commands to run after each prompt.
B<>> I<expr> Define Perl command to run after each prompt.
B<>>B<>> I<expr> Add to the list of Perl commands to run after each prompt.
-B<>>B< *> Delete the list of Perl commands to run after each prompt.
+B<>>B< *> Delete the list of Perl commands to run after each prompt.
B<{> I<db_command> Define debugger command to run before each prompt.
B<{> ? List debugger commands to run before each prompt.
+B<{ *> Delete the list of debugger commands to run before each prompt.
B<{{> I<db_command> Add to the list of debugger commands to run before each prompt.
-B<{ *> Delete the list of debugger commands to run before each prompt.
B<$prc> I<number> Redo a previous command (default previous command).
B<$prc> I<-number> Redo number'th-to-last command.
B<$prc> I<pattern> Redo last command that started with I<pattern>.
See 'B<O> I<recallCommand>' too.
B<$psh$psh> I<cmd> Run cmd in a subprocess (reads from DB::IN, writes to DB::OUT)"
- . ( $rc eq $sh ? "" : "
-B<$psh> [I<cmd>] Run I<cmd> in subshell (forces \"\$SHELL -c 'cmd'\")." ) . "
+ . (
+ $rc eq $sh
+ ? ""
+ : "
+B<$psh> [I<cmd>] Run I<cmd> in subshell (forces \"\$SHELL -c 'cmd'\")."
+ )
+ . "
See 'B<O> I<shellBang>' too.
B<source> I<file> Execute I<file> containing debugger commands (may nest).
B<H> I<-number> Display last number commands (default all).
Type `|h h' for a paged display if this was too hard to read.
-"; # Fix balance of vi % matching: }}}}
+"; # Fix balance of vi % matching: }}}}
# note: tabs in the following section are not-so-helpful
$summary = <<"END_SUM";
B<y> [I<n> [I<Vars>]] List lexicals in higher scope <n>. Vars same as B<V>.
For more help, type B<h> I<cmd_letter>, or run B<$doccmd perldebug> for all docs.
END_SUM
- # ')}}; # Fix balance of vi % matching
- # and this is really numb...
- $pre580_help = "
+ # ')}}; # Fix balance of vi % matching
+
+ # and this is really numb...
+ $pre580_help = "
B<T> Stack trace.
B<s> [I<expr>] Single step [in I<expr>].
B<n> [I<expr>] Next, steps over subroutine calls [in I<expr>].
-<B<CR>> Repeat last B<n> or B<s> command.
+B<CR>> Repeat last B<n> or B<s> command.
B<r> Return from current subroutine.
B<c> [I<line>|I<sub>] Continue; optionally inserts a one-time-only breakpoint
at the specified position.
B<$prc> I<pattern> Redo last command that started with I<pattern>.
See 'B<O> I<recallCommand>' too.
B<$psh$psh> I<cmd> Run cmd in a subprocess (reads from DB::IN, writes to DB::OUT)"
- . ( $rc eq $sh ? "" : "
-B<$psh> [I<cmd>] Run I<cmd> in subshell (forces \"\$SHELL -c 'cmd'\")." ) . "
+ . (
+ $rc eq $sh
+ ? ""
+ : "
+B<$psh> [I<cmd>] Run I<cmd> in subshell (forces \"\$SHELL -c 'cmd'\")."
+ ) .
+ "
See 'B<O> I<shellBang>' too.
B<source> I<file> Execute I<file> containing debugger commands (may nest).
B<H> I<-number> Display last number commands (default all).
Type `|h' for a paged display if this was too hard to read.
-"; # Fix balance of vi % matching: }}}}
+"; # Fix balance of vi % matching: }}}}
# note: tabs in the following section are not-so-helpful
$pre580_summary = <<"END_SUM";
B<y> [I<n> [I<Vars>]] List lexicals in higher scope <n>. Vars same as B<V>.
For more help, type B<h> I<cmd_letter>, or run B<$doccmd perldebug> for all docs.
END_SUM
- # ')}}; # Fix balance of vi % matching
-}
+ # ')}}; # Fix balance of vi % matching
+
+} ## end sub sethelp
+
+=head2 C<print_help()>
+
+Most of what C<print_help_ does is just text formatting. It finds the
+C<B> and C<I> ornaments, cleans them off, and substitutes the proper
+terminal control characters to simulate them (courtesy of
+<Term::ReadLine::TermCap>).
+
+=cut
sub print_help {
local $_ = shift;
# the first tab sequence padded into a field 16 (or if indented 20)
# wide. If it's wider than that, an extra space will be added.
s{
- ^ # only matters at start of line
- ( \040{4} | \t )* # some subcommands are indented
- ( < ? # so <CR> works
- [BI] < [^\t\n] + ) # find an eeevil ornament
- ( \t+ ) # original separation, discarded
- ( .* ) # this will now start (no earlier) than
- # column 16
+ ^ # only matters at start of line
+ ( \040{4} | \t )* # some subcommands are indented
+ ( < ? # so <CR> works
+ [BI] < [^\t\n] + ) # find an eeevil ornament
+ ( \t+ ) # original separation, discarded
+ ( .* ) # this will now start (no earlier) than
+ # column 16
} {
- my($leadwhite, $command, $midwhite, $text) = ($1, $2, $3, $4);
- my $clean = $command;
- $clean =~ s/[BI]<([^>]*)>/$1/g;
- # replace with this whole string:
- ($leadwhite ? " " x 4 : "")
+ my($leadwhite, $command, $midwhite, $text) = ($1, $2, $3, $4);
+ my $clean = $command;
+ $clean =~ s/[BI]<([^>]*)>/$1/g;
+
+ # replace with this whole string:
+ ($leadwhite ? " " x 4 : "")
. $command
. ((" " x (16 + ($leadwhite ? 4 : 0) - length($clean))) || " ")
. $text;
}mgex;
- s{ # handle bold ornaments
- B < ( [^>] + | > ) >
+ s{ # handle bold ornaments
+ B < ( [^>] + | > ) >
} {
- $Term::ReadLine::TermCap::rl_term_set[2]
- . $1
- . $Term::ReadLine::TermCap::rl_term_set[3]
+ $Term::ReadLine::TermCap::rl_term_set[2]
+ . $1
+ . $Term::ReadLine::TermCap::rl_term_set[3]
}gex;
- s{ # handle italic ornaments
- I < ( [^>] + | > ) >
+ s{ # handle italic ornaments
+ I < ( [^>] + | > ) >
} {
- $Term::ReadLine::TermCap::rl_term_set[0]
- . $1
- . $Term::ReadLine::TermCap::rl_term_set[1]
+ $Term::ReadLine::TermCap::rl_term_set[0]
+ . $1
+ . $Term::ReadLine::TermCap::rl_term_set[1]
}gex;
local $\ = '';
print $OUT $_;
-}
+} ## end sub print_help
+
+=head2 C<fix_less>
+
+This routine does a lot of gyrations to be sure that the pager is C<less>.
+It checks for C<less> masquerading as C<more> and records the result in
+C<$ENV{LESS}> so we don't have to go through doing the stats again.
+
+=cut
sub fix_less {
+
+ # We already know if this is set.
return if defined $ENV{LESS} && $ENV{LESS} =~ /r/;
+
+ # Pager is less for sure.
my $is_less = $pager =~ /\bless\b/;
- if ($pager =~ /\bmore\b/) {
- my @st_more = stat('/usr/bin/more');
- my @st_less = stat('/usr/bin/less');
- $is_less = @st_more && @st_less
- && $st_more[0] == $st_less[0]
- && $st_more[1] == $st_less[1];
- }
+ if ($pager =~ /\bmore\b/) {
+ # Nope, set to more. See what's out there.
+ my @st_more = stat('/usr/bin/more');
+ my @st_less = stat('/usr/bin/less');
+
+ # is it really less, pretending to be more?
+ $is_less = @st_more &&
+ @st_less &&
+ $st_more[0] == $st_less[0] &&
+ $st_more[1] == $st_less[1];
+ } ## end if ($pager =~ /\bmore\b/)
+
# changes environment!
- $ENV{LESS} .= 'r' if $is_less;
-}
+ # 'r' added so we don't do (slow) stats again.
+ $ENV{LESS} .= 'r' if $is_less;
+} ## end sub fix_less
+
+=head1 DIE AND WARN MANAGEMENT
+
+=head2 C<diesignal>
+
+C<diesignal> is a just-drop-dead C<die> handler. It's most useful when trying
+to debug a debugger problem.
+
+It does its best to report the error that occurred, and then forces the
+program, debugger, and everything to die.
+
+=cut
sub diesignal {
+ # No entry/exit messages.
local $frame = 0;
+
+ # No return value prints.
local $doret = -2;
+
+ # set the abort signal handling to the default (just terminate).
$SIG{'ABRT'} = 'DEFAULT';
+
+ # If we enter the signal handler recursively, kill myself with an
+ # abort signal (so we just terminate).
kill 'ABRT', $$ if $panic++;
+
+ # If we can show detailed info, do so.
if (defined &Carp::longmess) {
- local $SIG{__WARN__} = '';
- local $Carp::CarpLevel = 2; # mydie + confess
- &warn(Carp::longmess("Signal @_"));
+ # Don't recursively enter the warn handler, since we're carping.
+ local $SIG{__WARN__} = '';
+
+ # Skip two levels before reporting traceback: we're skipping
+ # mydie and confess.
+ local $Carp::CarpLevel = 2; # mydie + confess
+
+ # Tell us all about it.
+ &warn(Carp::longmess("Signal @_"));
}
+
+ # No Carp. Tell us about the signal as best we can.
else {
- local $\ = '';
- print $DB::OUT "Got signal @_\n";
+ local $\ = '';
+ print $DB::OUT "Got signal @_\n";
}
+
+ # Drop dead.
kill 'ABRT', $$;
-}
+} ## end sub diesignal
-sub dbwarn {
- local $frame = 0;
- local $doret = -2;
- local $SIG{__WARN__} = '';
- local $SIG{__DIE__} = '';
- eval { require Carp } if defined $^S; # If error/warning during compilation,
- # require may be broken.
- CORE::warn(@_, "\nCannot print stack trace, load with -MCarp option to see stack"),
- return unless defined &Carp::longmess;
- my ($mysingle,$mytrace) = ($single,$trace);
- $single = 0; $trace = 0;
- my $mess = Carp::longmess(@_);
- ($single,$trace) = ($mysingle,$mytrace);
- &warn($mess);
-}
+=head2 C<dbwarn>
+
+The debugger's own default C<$SIG{__WARN__}> handler. We load C<Carp> to
+be able to get a stack trace, and output the warning message vi C<DB::dbwarn()>.
+
+=cut
+
+sub dbwarn {
+ # No entry/exit trace.
+ local $frame = 0;
+
+ # No return value printing.
+ local $doret = -2;
+
+ # Turn off warn and die handling to prevent recursive entries to this
+ # routine.
+ local $SIG{__WARN__} = '';
+ local $SIG{__DIE__} = '';
+
+ # Load Carp if we can. If $^S is false (current thing being compiled isn't
+ # done yet), we may not be able to do a require.
+ eval { require Carp }
+ if defined $^S; # If error/warning during compilation,
+ # require may be broken.
+
+ # Use the core warn() unless Carp loaded OK.
+ CORE::warn(@_,
+ "\nCannot print stack trace, load with -MCarp option to see stack"),
+ return
+ unless defined &Carp::longmess;
+
+ # Save the current values of $single and $trace, and then turn them off.
+ my ($mysingle, $mytrace) = ($single, $trace);
+ $single = 0;
+ $trace = 0;
+
+ # We can call Carp::longmess without its being "debugged" (which we
+ # don't want - we just want to use it!). Capture this for later.
+ my $mess = Carp::longmess(@_);
+
+ # Restore $single and $trace to their original values.
+ ($single, $trace) = ($mysingle, $mytrace);
+
+ # Use the debugger's own special way of printing warnings to print
+ # the stack trace message.
+ &warn($mess);
+} ## end sub dbwarn
+
+=head2 C<dbdie>
+
+The debugger's own C<$SIG{__DIE__}> handler. Handles providing a stack trace
+by loading C<Carp> and calling C<Carp::longmess()> to get it. We turn off
+single stepping and tracing during the call to C<Carp::longmess> to avoid
+debugging it - we just want to use it.
+
+If C<dieLevel> is zero, we let the program being debugged handle the
+exceptions. If it's 1, you get backtraces for any exception. If it's 2,
+the debugger takes over all exception handling, printing a backtrace and
+displaying the exception via its C<dbwarn()> routine.
+
+=cut
sub dbdie {
- local $frame = 0;
- local $doret = -2;
- local $SIG{__DIE__} = '';
- local $SIG{__WARN__} = '';
- my $i = 0; my $ineval = 0; my $sub;
- if ($dieLevel > 2) {
- local $SIG{__WARN__} = \&dbwarn;
- &warn(@_); # Yell no matter what
- return;
- }
- if ($dieLevel < 2) {
- die @_ if $^S; # in eval propagate
- }
- # No need to check $^S, eval is much more robust nowadays
- eval { require Carp }; #if defined $^S;# If error/warning during compilation,
- # require may be broken.
-
- die(@_, "\nCannot print stack trace, load with -MCarp option to see stack")
- unless defined &Carp::longmess;
-
- # We do not want to debug this chunk (automatic disabling works
- # inside DB::DB, but not in Carp).
- my ($mysingle,$mytrace) = ($single,$trace);
- $single = 0; $trace = 0;
- my $mess = "@_";
- {
- package Carp; # Do not include us in the list
- eval {
- $mess = Carp::longmess(@_);
- };
- }
- ($single,$trace) = ($mysingle,$mytrace);
- die $mess;
-}
+ local $frame = 0;
+ local $doret = -2;
+ local $SIG{__DIE__} = '';
+ local $SIG{__WARN__} = '';
+ my $i = 0;
+ my $ineval = 0;
+ my $sub;
+ if ($dieLevel > 2) {
+ local $SIG{__WARN__} = \&dbwarn;
+ &warn(@_); # Yell no matter what
+ return;
+ }
+ if ($dieLevel < 2) {
+ die @_ if $^S; # in eval propagate
+ }
+
+ # The code used to check $^S to see if compiliation of the current thing
+ # hadn't finished. We don't do it anymore, figuring eval is pretty stable.
+ eval { require Carp };
+
+ die (@_,
+ "\nCannot print stack trace, load with -MCarp option to see stack")
+ unless defined &Carp::longmess;
+
+ # We do not want to debug this chunk (automatic disabling works
+ # inside DB::DB, but not in Carp). Save $single and $trace, turn them off,
+ # get the stack trace from Carp::longmess (if possible), restore $signal
+ # and $trace, and then die with the stack trace.
+ my ($mysingle, $mytrace) = ($single, $trace);
+ $single = 0;
+ $trace = 0;
+ my $mess = "@_";
+ {
+
+ package Carp; # Do not include us in the list
+ eval { $mess = Carp::longmess(@_); };
+ }
+ ($single, $trace) = ($mysingle, $mytrace);
+ die $mess;
+} ## end sub dbdie
+
+=head2 C<warnlevel()>
+
+Set the C<$DB::warnLevel> variable that stores the value of the C<warnLevel>
+option. Calling C<warnLevel()> with a positive value results in the debugger taking over all warning handlers.Setting C<warnLevel> to zero leaves any warning
+handlers set up by the program being debugged in place.
+
+=cut
sub warnLevel {
- if (@_) {
- $prevwarn = $SIG{__WARN__} unless $warnLevel;
- $warnLevel = shift;
- if ($warnLevel) {
- $SIG{__WARN__} = \&DB::dbwarn;
- } elsif ($prevwarn) {
- $SIG{__WARN__} = $prevwarn;
- }
- }
- $warnLevel;
-}
+ if (@_) {
+ $prevwarn = $SIG{__WARN__} unless $warnLevel;
+ $warnLevel = shift;
+ if ($warnLevel) {
+ $SIG{__WARN__} = \&DB::dbwarn;
+ }
+ elsif ($prevwarn) {
+ $SIG{__WARN__} = $prevwarn;
+ }
+ } ## end if (@_)
+ $warnLevel;
+} ## end sub warnLevel
+
+=head2 C<dielevel>
+
+Similar to C<warnLevel>. Non-zero values for C<dieLevel> result in the
+C<DB::dbdie()> function overriding any other C<die()> handler. Setting it to
+zero lets you use your own C<die()> handler.
+
+=cut
sub dieLevel {
- local $\ = '';
- if (@_) {
- $prevdie = $SIG{__DIE__} unless $dieLevel;
- $dieLevel = shift;
- if ($dieLevel) {
- $SIG{__DIE__} = \&DB::dbdie; # if $dieLevel < 2;
- #$SIG{__DIE__} = \&DB::diehard if $dieLevel >= 2;
- print $OUT "Stack dump during die enabled",
- ( $dieLevel == 1 ? " outside of evals" : ""), ".\n"
- if $I_m_init;
- print $OUT "Dump printed too.\n" if $dieLevel > 2;
- } elsif ($prevdie) {
- $SIG{__DIE__} = $prevdie;
- print $OUT "Default die handler restored.\n";
- }
- }
- $dieLevel;
-}
+ local $\ = '';
+ if (@_) {
+ $prevdie = $SIG{__DIE__} unless $dieLevel;
+ $dieLevel = shift;
+ if ($dieLevel) {
+ # Always set it to dbdie() for non-zero values.
+ $SIG{__DIE__} = \&DB::dbdie; # if $dieLevel < 2;
+
+ # No longer exists, so don't try to use it.
+ #$SIG{__DIE__} = \&DB::diehard if $dieLevel >= 2;
+
+ # If we've finished initialization, mention that stack dumps
+ # are enabled, If dieLevel is 1, we won't stack dump if we die
+ # in an eval().
+ print $OUT "Stack dump during die enabled",
+ ($dieLevel == 1 ? " outside of evals" : ""), ".\n"
+ if $I_m_init;
+
+ # XXX This is probably obsolete, given that diehard() is gone.
+ print $OUT "Dump printed too.\n" if $dieLevel > 2;
+ } ## end if ($dieLevel)
+
+ # Put the old one back if there was one.
+ elsif ($prevdie) {
+ $SIG{__DIE__} = $prevdie;
+ print $OUT "Default die handler restored.\n";
+ }
+ } ## end if (@_)
+ $dieLevel;
+} ## end sub dieLevel
+
+=head2 C<signalLevel>
+
+Number three in a series: set C<signalLevel> to zero to keep your own
+signal handler for C<SIGSEGV> and/or C<SIGBUS>. Oherwise, the debugger
+takes over and handles them with C<DB::diesignal()>.
+
+=cut
sub signalLevel {
- if (@_) {
- $prevsegv = $SIG{SEGV} unless $signalLevel;
- $prevbus = $SIG{BUS} unless $signalLevel;
- $signalLevel = shift;
- if ($signalLevel) {
- $SIG{SEGV} = \&DB::diesignal;
- $SIG{BUS} = \&DB::diesignal;
- } else {
- $SIG{SEGV} = $prevsegv;
- $SIG{BUS} = $prevbus;
- }
- }
- $signalLevel;
-}
+ if (@_) {
+ $prevsegv = $SIG{SEGV} unless $signalLevel;
+ $prevbus = $SIG{BUS} unless $signalLevel;
+ $signalLevel = shift;
+ if ($signalLevel) {
+ $SIG{SEGV} = \&DB::diesignal;
+ $SIG{BUS} = \&DB::diesignal;
+ }
+ else {
+ $SIG{SEGV} = $prevsegv;
+ $SIG{BUS} = $prevbus;
+ }
+ } ## end if (@_)
+ $signalLevel;
+} ## end sub signalLevel
+
+=head1 SUBROUTINE DECODING SUPPORT
+
+These subroutines are used duting the C<x> and C<X> commands to try to
+produce as much information as possible about a code reference. They use
+L<Devel::Peek> to try to find the glob in which this code reference lives
+(if it does) - this allows us to actually code references which correspond
+to named subroutines (including those aliased via glob assignment).
+
+=head2 C<CvGV_name()>
+
+Wrapper for X<CvGV_name_or_bust>; tries to get the name of a reference
+via that routine. If this fails, return the reference again (when the
+reference is stringified, it'll come out as "SOMETHING(0X...)").
+
+=cut
sub CvGV_name {
- my $in = shift;
- my $name = CvGV_name_or_bust($in);
- defined $name ? $name : $in;
+ my $in = shift;
+ my $name = CvGV_name_or_bust($in);
+ defined $name ? $name : $in;
}
+=head2 C<CvGV_name_or_bust> I<coderef>
+
+Calls L<Devel::Peek> to try to find the glob the ref lives in; returns
+C<undef> if L<Devel::Peek> can't be loaded, or if C<Devel::Peek::CvGV> can't
+find a glob for this ref.
+
+Returns "I<package>::I<glob name>" if the code ref is found in a glob.
+
+=cut
+
sub CvGV_name_or_bust {
- my $in = shift;
- return if $skipCvGV; # Backdoor to avoid problems if XS broken...
- return unless ref $in;
- $in = \&$in; # Hard reference...
- eval {require Devel::Peek; 1} or return;
- my $gv = Devel::Peek::CvGV($in) or return;
- *$gv{PACKAGE} . '::' . *$gv{NAME};
-}
+ my $in = shift;
+ return if $skipCvGV; # Backdoor to avoid problems if XS broken...
+ return unless ref $in;
+ $in = \&$in; # Hard reference...
+ eval { require Devel::Peek; 1 } or return;
+ my $gv = Devel::Peek::CvGV($in) or return;
+ *$gv{PACKAGE} . '::' . *$gv{NAME};
+} ## end sub CvGV_name_or_bust
+
+=head2 C<find_sub>
+
+A utility routine used in various places; finds the file where a subroutine
+was defined, and returns that filename and a line-number range.
+
+Tries to use X<@sub> first; if it can't find it there, it tries building a
+reference to the subroutine and uses X<CvGV_name_or_bust> to locate it,
+loading it into X<@sub> as a side effect (XXX I think). If it can't find it
+this way, it brute-force searches X<%sub>, checking for identical references.
+
+=cut
sub find_sub {
- my $subr = shift;
- $sub{$subr} or do {
- return unless defined &$subr;
- my $name = CvGV_name_or_bust($subr);
- my $data;
- $data = $sub{$name} if defined $name;
- return $data if defined $data;
-
- # Old stupid way...
- $subr = \&$subr; # Hard reference
- my $s;
- for (keys %sub) {
- $s = $_, last if $subr eq \&$_;
+ my $subr = shift;
+ $sub{$subr} or do {
+ return unless defined &$subr;
+ my $name = CvGV_name_or_bust($subr);
+ my $data;
+ $data = $sub{$name} if defined $name;
+ return $data if defined $data;
+
+ # Old stupid way...
+ $subr = \&$subr; # Hard reference
+ my $s;
+ for (keys %sub) {
+ $s = $_, last if $subr eq \&$_;
+ }
+ $sub{$s} if $s;
+ } ## end do
+} ## end sub find_sub
+
+=head2 C<methods>
+
+A subroutine that uses the utility function X<methods_via> to find all the
+methods in the class corresponding to the current reference and in
+C<UNIVERSAL>.
+
+=cut
+
+sub methods {
+
+ # Figure out the class - either this is the class or it's a reference
+ # to something blessed into that class.
+ my $class = shift;
+ $class = ref $class if ref $class;
+
+ local %seen;
+ local %packs;
+
+ # Show the methods that this class has.
+ methods_via($class, '', 1);
+
+ # Show the methods that UNIVERSAL has.
+ methods_via('UNIVERSAL', 'UNIVERSAL', 0);
+} ## end sub methods
+
+=head2 C<methods_via($class, $prefix, $crawl_upward)>
+
+C<methods_via> does the work of crawling up the C<@ISA> tree and reporting
+all the parent class methods. C<$class> is the name of the next class to
+try; C<$prefix> is the message prefix, which gets built up as we go up the
+C<@ISA> tree to show parentage; C<$crawl_upward> is 1 if we should try to go
+higher in the C<@ISA> tree, 0 if we should stop.
+
+=cut
+
+sub methods_via {
+ # If we've processed this class already, just quit.
+ my $class = shift;
+
+ # XXX This may be a bug - no other references to %packs.
+ return if $packs{$class}++;
+
+ # This is a package that is contributing the methods we're about to print.
+ my $prefix = shift;
+ my $prepend = $prefix ? "via $prefix: " : '';
+
+ my $name;
+ for $name (
+ # Keep if this is a defined subroutine in this class.
+ grep { defined &{ ${"${class}::"}{$_} } }
+ # Extract from all the symbols in this class.
+ sort keys %{"${class}::"}
+ ) {
+ # XXX This should probably be %packs (or %packs should be %seen).
+ next if $seen{$name}++;
+ local $\ = '';
+ local $, = '';
+ print $DB::OUT "$prepend$name\n";
+ } ## end for $name (grep { defined...
+
+ # If the $crawl_upward argument is false, just quit here.
+ return unless shift;
+
+ # $crawl_upward true: keep going up the tree.
+ # Find all the classes this one is a subclass of.
+ for $name (@{"${class}::ISA"}) {
+ # Set up the new prefix.
+ $prepend = $prefix ? $prefix . " -> $name" : $name;
+ # Crawl up the tree and keep trying to crawl up.
+ methods_via($name, $prepend, 1);
}
- $sub{$s} if $s;
- }
-}
+} ## end sub methods_via
+
+=head2 C<setman> - figure out which command to use to show documentation
-sub methods {
- my $class = shift;
- $class = ref $class if ref $class;
- local %seen;
- local %packs;
- methods_via($class, '', 1);
- methods_via('UNIVERSAL', 'UNIVERSAL', 0);
-}
+Just checks the contents of C<$^O> and sets the C<$doccmd> global accordingly.
-sub methods_via {
- my $class = shift;
- return if $packs{$class}++;
- my $prefix = shift;
- my $prepend = $prefix ? "via $prefix: " : '';
- my $name;
- for $name (grep {defined &{${"${class}::"}{$_}}}
- sort keys %{"${class}::"}) {
- next if $seen{ $name }++;
- local $\ = '';
- local $, = '';
- print $DB::OUT "$prepend$name\n";
- }
- return unless shift; # Recurse?
- for $name (@{"${class}::ISA"}) {
- $prepend = $prefix ? $prefix . " -> $name" : $name;
- methods_via($name, $prepend, 1);
- }
-}
+=cut
-sub setman {
- $doccmd = $^O !~ /^(?:MSWin32|VMS|os2|dos|amigaos|riscos|MacOS|NetWare)\z/s
- ? "man" # O Happy Day!
- : "perldoc"; # Alas, poor unfortunates
-}
+sub setman {
+ $doccmd =
+ $^O !~ /^(?:MSWin32|VMS|os2|dos|amigaos|riscos|MacOS|NetWare)\z/s
+ ? "man" # O Happy Day!
+ : "perldoc"; # Alas, poor unfortunates
+} ## end sub setman
+
+=head2 C<runman> - run the appropriate command to show documentation
+
+Accepts a man page name; runs the appropriate command to display it (set up
+during debugger initialization). Uses C<DB::system> to avoid mucking up the
+program's STDIN and STDOUT.
+
+=cut
sub runman {
my $page = shift;
unless ($page) {
- &system("$doccmd $doccmd");
- return;
- }
+ &system("$doccmd $doccmd");
+ return;
+ }
+
# this way user can override, like with $doccmd="man -Mwhatever"
# or even just "man " to disable the path check.
unless ($doccmd eq 'man') {
- &system("$doccmd $page");
- return;
- }
+ &system("$doccmd $page");
+ return;
+ }
$page = 'perl' if lc($page) eq 'help';
require Config;
my $man1dir = $Config::Config{'man1dir'};
my $man3dir = $Config::Config{'man3dir'};
- for ($man1dir, $man3dir) { s#/[^/]*\z## if /\S/ }
+ for ($man1dir, $man3dir) { s#/[^/]*\z## if /\S/ }
my $manpath = '';
$manpath .= "$man1dir:" if $man1dir =~ /\S/;
$manpath .= "$man3dir:" if $man3dir =~ /\S/ && $man1dir ne $man3dir;
chop $manpath if $manpath;
+
# harmless if missing, I figure
my $oldpath = $ENV{MANPATH};
$ENV{MANPATH} = $manpath if $manpath;
my $nopathopt = $^O =~ /dunno what goes here/;
- if (CORE::system($doccmd,
- # I just *know* there are men without -M
- (($manpath && !$nopathopt) ? ("-M", $manpath) : ()),
- split ' ', $page) )
+ if (
+ CORE::system(
+ $doccmd,
+
+ # I just *know* there are men without -M
+ (($manpath && !$nopathopt) ? ("-M", $manpath) : ()),
+ split ' ', $page
+ )
+ )
{
- unless ($page =~ /^perl\w/) {
- if (grep { $page eq $_ } qw{
- 5004delta 5005delta amiga api apio book boot bot call compile
- cygwin data dbmfilter debug debguts delta diag doc dos dsc embed
- faq faq1 faq2 faq3 faq4 faq5 faq6 faq7 faq8 faq9 filter fork
- form func guts hack hist hpux intern ipc lexwarn locale lol mod
- modinstall modlib number obj op opentut os2 os390 pod port
- ref reftut run sec style sub syn thrtut tie toc todo toot tootc
- trap unicode var vms win32 xs xstut
- })
- {
- $page =~ s/^/perl/;
- CORE::system($doccmd,
- (($manpath && !$nopathopt) ? ("-M", $manpath) : ()),
- $page);
- }
- }
- }
+ unless ($page =~ /^perl\w/) {
+ if (
+ grep { $page eq $_ }
+ qw{
+ 5004delta 5005delta amiga api apio book boot bot call compile
+ cygwin data dbmfilter debug debguts delta diag doc dos dsc embed
+ faq faq1 faq2 faq3 faq4 faq5 faq6 faq7 faq8 faq9 filter fork
+ form func guts hack hist hpux intern ipc lexwarn locale lol mod
+ modinstall modlib number obj op opentut os2 os390 pod port
+ ref reftut run sec style sub syn thrtut tie toc todo toot tootc
+ trap unicode var vms win32 xs xstut
+ }
+ )
+ {
+ $page =~ s/^/perl/;
+ CORE::system($doccmd,
+ (($manpath && !$nopathopt) ? ("-M", $manpath) : ()),
+ $page);
+ } ## end if (grep { $page eq $_...
+ } ## end unless ($page =~ /^perl\w/)
+ } ## end if (CORE::system($doccmd...
if (defined $oldpath) {
- $ENV{MANPATH} = $manpath;
- } else {
- delete $ENV{MANPATH};
- }
-}
+ $ENV{MANPATH} = $manpath;
+ }
+ else {
+ delete $ENV{MANPATH};
+ }
+} ## end sub runman
+
+#use Carp; # This did break, left for debugging
+
+=head1 DEBUGGER INITIALIZATION - THE SECOND BEGIN BLOCK
+
+Because of the way the debugger interface to the Perl core is designed, any
+debugger package globals that C<DB::sub()> requires have to be defined before
+any subroutines can be called. These are defined in the second C<BEGIN> block.
+
+This block sets things up so that (basically) the world is sane
+before the debugger starts executing. We set up various variables that the
+debugger has to have set up before the Perl core starts running:
+
+=over 4
+
+=item * The debugger's own filehandles (copies of STD and STDOUT for now).
+
+=item * Characters for shell escapes, the recall command, and the history command.
+
+=item * The maximum recursion depth.
+
+=item * The size of a C<w> command's window.
+
+=item * The before-this-line context to be printed in a C<v> (view a window around this line) command.
+
+=item * The fact that we're not in a sub at all right now.
+
+=item * The default SIGINT handler for the debugger.
+
+=item * The appropriate value of the flag in C<$^D> that says the debugger is running
+
+=item * The current debugger recursion level
+
+=item * The list of postponed (XXX define) items and the C<$single> stack
+
+=item * That we want no return values and no subroutine entry/exit trace.
+
+=cut
# The following BEGIN is very handy if debugger goes havoc, debugging debugger?
-BEGIN { # This does not compile, alas.
- $IN = \*STDIN; # For bugs before DB::OUT has been opened
- $OUT = \*STDERR; # For errors before DB::OUT has been opened
- $sh = '!';
- $rc = ',';
- @hist = ('?');
- $deep = 100; # warning if stack gets this deep
- $window = 10;
- $preview = 3;
- $sub = '';
- $SIG{INT} = \&DB::catch;
- # This may be enabled to debug debugger:
- #$warnLevel = 1 unless defined $warnLevel;
- #$dieLevel = 1 unless defined $dieLevel;
- #$signalLevel = 1 unless defined $signalLevel;
-
- $db_stop = 0; # Compiler warning
- $db_stop = 1 << 30;
- $level = 0; # Level of recursive debugging
- # @stack and $doret are needed in sub sub, which is called for DB::postponed.
- # Triggers bug (?) in perl is we postpone this until runtime:
- @postponed = @stack = (0);
- $stack_depth = 0; # Localized $#stack
- $doret = -2;
- $frame = 0;
-}
+BEGIN { # This does not compile, alas. (XXX eh?)
+ $IN = \*STDIN; # For bugs before DB::OUT has been opened
+ $OUT = \*STDERR; # For errors before DB::OUT has been opened
+
+ # Define characters used by command parsing.
+ $sh = '!'; # Shell escape (does not work)
+ $rc = ','; # Recall command (does not work)
+ @hist = ('?'); # Show history (does not work)
+
+ # This defines the point at which you get the 'deep recursion'
+ # warning. It MUST be defined or the debugger will not load.
+ $deep = 100;
+
+ # Number of lines around the current one that are shown in the
+ # 'w' command.
+ $window = 10;
+
+ # How much before-the-current-line context the 'v' command should
+ # use in calculating the start of the window it will display.
+ $preview = 3;
+
+ # We're not in any sub yet, but we need this to be a defined value.
+ $sub = '';
+
+ # Set up the debugger's interrupt handler. It simply sets a flag
+ # ($signal) that DB::DB() will check before each command is executed.
+ $SIG{INT} = \&DB::catch;
+
+ # The following lines supposedly, if uncommented, allow the debugger to
+ # debug itself. Perhaps we can try that someday.
+ # This may be enabled to debug debugger:
+ #$warnLevel = 1 unless defined $warnLevel;
+ #$dieLevel = 1 unless defined $dieLevel;
+ #$signalLevel = 1 unless defined $signalLevel;
+
+ # This is the flag that says "a debugger is running, please call
+ # DB::DB and DB::sub". We will turn it on forcibly before we try to
+ # execute anything in the user's context, because we always want to
+ # get control back.
+ $db_stop = 0; # Compiler warning ...
+ $db_stop = 1 << 30; # ... because this is only used in an eval() later.
+
+ # This variable records how many levels we're nested in debugging. Used
+ # Used in the debugger prompt, and in determining whether it's all over or
+ # not.
+ $level = 0; # Level of recursive debugging
+
+ # "Triggers bug (?) in perl if we postpone this until runtime."
+ # XXX No details on this yet, or whether we should fix the bug instead
+ # of work around it. Stay tuned.
+ @postponed = @stack = (0);
+
+ # Used to track the current stack depth using the auto-stacked-variable
+ # trick.
+ $stack_depth = 0; # Localized repeatedly; simple way to track $#stack
+
+ # Don't print return values on exiting a subroutine.
+ $doret = -2;
+
+ # No extry/exit tracing.
+ $frame = 0;
-BEGIN {$^W = $ini_warn;} # Switch warnings back
+} ## end BEGIN
-#use Carp; # This did break, left for debugging
+BEGIN { $^W = $ini_warn; } # Switch warnings back
+
+=head1 READLINE SUPPORT - COMPLETION FUNCTION
+
+=head2 db_complete
+
+C<readline> support - adds command completion to basic C<readline>.
+
+Returns a list of possible completions to C<readline> when invoked. C<readline>
+will print the longest common substring following the text already entered.
+
+If there is only a single possible completion, C<readline> will use it in full.
+
+This code uses C<map> and C<grep> heavily to create lists of possible
+completion. Think LISP in this section.
+
+=cut
sub db_complete {
- # Specific code for b c l V m f O, &blah, $blah, @blah, %blah
- my($text, $line, $start) = @_;
- my ($itext, $search, $prefix, $pack) =
- ($text, "^\Q${'package'}::\E([^:]+)\$");
-
- return sort grep /^\Q$text/, (keys %sub), qw(postpone load compile), # subroutines
- (map { /$search/ ? ($1) : () } keys %sub)
- if (substr $line, 0, $start) =~ /^\|*[blc]\s+((postpone|compile)\s+)?$/;
- return sort grep /^\Q$text/, values %INC # files
- if (substr $line, 0, $start) =~ /^\|*b\s+load\s+$/;
- return sort map {($_, db_complete($_ . "::", "V ", 2))}
- grep /^\Q$text/, map { /^(.*)::$/ ? ($1) : ()} keys %:: # top-packages
+
+ # Specific code for b c l V m f O, &blah, $blah, @blah, %blah
+ # $text is the text to be completed.
+ # $line is the incoming line typed by the user.
+ # $start is the start of the text to be completed in the incoming line.
+ my ($text, $line, $start) = @_;
+
+ # Save the initial text.
+ # The search pattern is current package, ::, extract the next qualifier
+ # Prefix and pack are set to undef.
+ my ($itext, $search, $prefix, $pack) =
+ ($text, "^\Q${'package'}::\E([^:]+)\$");
+
+=head3 C<b postpone|compile>
+
+=over 4
+
+=item * Find all the subroutines that might match in this package
+
+=item * Add "postpone", "load", and "compile" as possibles (we may be completing the keyword itself
+
+=item * Include all the rest of the subs that are known
+
+=item * C<grep> out the ones that match the text we have so far
+
+=item * Return this as the list of possible completions
+
+=cut
+
+ return sort grep /^\Q$text/, (keys %sub),
+ qw(postpone load compile), # subroutines
+ (map { /$search/ ? ($1) : () } keys %sub)
+ if (substr $line, 0, $start) =~ /^\|*[blc]\s+((postpone|compile)\s+)?$/;
+
+=head3 C<b load>
+
+Get all the possible files from @INC as it currently stands and
+select the ones that match the text so far.
+
+=cut
+
+ return sort grep /^\Q$text/, values %INC # files
+ if (substr $line, 0, $start) =~ /^\|*b\s+load\s+$/;
+
+=head3 C<V> (list variable) and C<m> (list modules)
+
+There are two entry points for these commands:
+
+=head4 Unqualified package names
+
+Get the top-level packages and grab everything that matches the text
+so far. For each match, recursively complete the partial packages to
+get all possible matching packages. Return this sorted list.
+
+=cut
+
+ return sort map { ($_, db_complete($_ . "::", "V ", 2)) }
+ grep /^\Q$text/, map { /^(.*)::$/ ? ($1) : () } keys %:: # top-packages
if (substr $line, 0, $start) =~ /^\|*[Vm]\s+$/ and $text =~ /^\w*$/;
- return sort map {($_, db_complete($_ . "::", "V ", 2))}
- grep !/^main::/,
- grep /^\Q$text/, map { /^(.*)::$/ ? ($prefix . "::$1") : ()} keys %{$prefix . '::'}
- # packages
- if (substr $line, 0, $start) =~ /^\|*[Vm]\s+$/
- and $text =~ /^(.*[^:])::?(\w*)$/ and $prefix = $1;
- if ( $line =~ /^\|*f\s+(.*)/ ) { # Loaded files
- # We may want to complete to (eval 9), so $text may be wrong
- $prefix = length($1) - length($text);
- $text = $1;
- return sort
- map {substr $_, 2 + $prefix} grep /^_<\Q$text/, (keys %main::), $0
- }
- if ((substr $text, 0, 1) eq '&') { # subroutines
- $text = substr $text, 1;
- $prefix = "&";
- return sort map "$prefix$_",
- grep /^\Q$text/,
- (keys %sub),
- (map { /$search/ ? ($1) : () }
- keys %sub);
- }
- if ($text =~ /^[\$@%](.*)::(.*)/) { # symbols in a package
- $pack = ($1 eq 'main' ? '' : $1) . '::';
- $prefix = (substr $text, 0, 1) . $1 . '::';
- $text = $2;
- my @out
- = map "$prefix$_", grep /^\Q$text/, grep /^_?[a-zA-Z]/, keys %$pack ;
- if (@out == 1 and $out[0] =~ /::$/ and $out[0] ne $itext) {
- return db_complete($out[0], $line, $start);
- }
- return sort @out;
- }
- if ($text =~ /^[\$@%]/) { # symbols (in $package + packages in main)
- $pack = ($package eq 'main' ? '' : $package) . '::';
- $prefix = substr $text, 0, 1;
- $text = substr $text, 1;
- my @out = map "$prefix$_", grep /^\Q$text/,
- (grep /^_?[a-zA-Z]/, keys %$pack),
- ( $pack eq '::' ? () : (grep /::$/, keys %::) ) ;
- if (@out == 1 and $out[0] =~ /::$/ and $out[0] ne $itext) {
- return db_complete($out[0], $line, $start);
- }
- return sort @out;
- }
- if ((substr $line, 0, $start) =~ /^\|*O\b.*\s$/) { # Options after a space
- my @out = grep /^\Q$text/, @options;
- my $val = option_val($out[0], undef);
- my $out = '? ';
- if (not defined $val or $val =~ /[\n\r]/) {
- # Can do nothing better
- } elsif ($val =~ /\s/) {
- my $found;
- foreach $l (split //, qq/\"\'\#\|/) {
- $out = "$l$val$l ", last if (index $val, $l) == -1;
- }
- } else {
- $out = "=$val ";
- }
- # Default to value if one completion, to question if many
- $rl_attribs->{completer_terminator_character} = (@out == 1 ? $out : '? ');
- return sort @out;
- }
- return $term->filename_list($text); # filenames
-}
+
+=head4 Qualified package names
+
+Take a partially-qualified package and find all subpackages for it
+by getting all the subpackages for the package so far, matching all
+the subpackages against the text, and discarding all of them which
+start with 'main::'. Return this list.
+
+=cut
+
+ return sort map { ($_, db_complete($_ . "::", "V ", 2)) }
+ grep !/^main::/, grep /^\Q$text/,
+ map { /^(.*)::$/ ? ($prefix . "::$1") : () } keys %{ $prefix . '::' }
+ if (substr $line, 0, $start) =~ /^\|*[Vm]\s+$/
+ and $text =~ /^(.*[^:])::?(\w*)$/
+ and $prefix = $1;
+
+=head3 C<f> - switch files
+
+Here, we want to get a fully-qualified filename for the C<f> command.
+Possibilities are:
+
+=over 4
+
+=item 1. The original source file itself
+
+=item 2. A file from C<@INC>
+
+=item 3. An C<eval> (the debugger gets a C<(eval N)> fake file for each C<eval>).
+
+=cut
+
+ if ($line =~ /^\|*f\s+(.*)/) { # Loaded files
+ # We might possibly want to switch to an eval (which has a "filename"
+ # like '(eval 9)'), so we may need to clean up the completion text
+ # before proceeding.
+ $prefix = length($1) - length($text);
+ $text = $1;
+
+=pod
+
+Under the debugger, source files are represented as C<_E<lt>/fullpath/to/file>
+(C<eval>s are C<_E<lt>(eval NNN)>) keys in C<%main::>. We pull all of these
+out of C<%main::>, add the initial source file, and extract the ones that
+match the completion text so far.
+
+=cut
+
+ return sort
+ map { substr $_, 2 + $prefix } grep /^_<\Q$text/, (keys %main::),
+ $0;
+ } ## end if ($line =~ /^\|*f\s+(.*)/)
+
+=head3 Subroutine name completion
+
+We look through all of the defined subs (the keys of C<%sub>) and
+return both all the possible matches to the subroutine name plus
+all the matches qualified to the current package.
+
+=cut
+
+ if ((substr $text, 0, 1) eq '&') { # subroutines
+ $text = substr $text, 1;
+ $prefix = "&";
+ return sort map "$prefix$_", grep /^\Q$text/, (keys %sub),
+ (
+ map { /$search/ ? ($1) : () }
+ keys %sub
+ );
+ } ## end if ((substr $text, 0, ...
+
+=head3 Scalar,array, and hash completion: partially qualified package
+
+Much like the above, except we have to do a little more cleanup:
+
+=over 4
+
+=cut
+
+ if ($text =~ /^[\$@%](.*)::(.*)/) { # symbols in a package
+
+=pod
+
+=item * Determine the package that the symbol is in. Put it in C<::> (effectively C<main::>) if no package is specified.
+
+=cut
+
+ $pack = ($1 eq 'main' ? '' : $1) . '::';
+
+=pod
+
+=item * Figure out the prefix vs. what needs completing.
+
+=cut
+
+ $prefix = (substr $text, 0, 1) . $1 . '::';
+ $text = $2;
+
+=pod
+
+=item * Look through all the symbols in the package. C<grep> out all the possible hashes/arrays/scalars, and then C<grep> the possible matches out of those. C<map> the prefix onto all the possibilities.
+
+=cut
+
+ my @out = map "$prefix$_", grep /^\Q$text/, grep /^_?[a-zA-Z]/,
+ keys %$pack;
+
+=pod
+
+=item * If there's only one hit, and it's a package qualifier, and it's not equal to the initial text, re-complete it using the symbol we actually found.
+
+=cut
+
+ if (@out == 1 and $out[0] =~ /::$/ and $out[0] ne $itext) {
+ return db_complete($out[0], $line, $start);
+ }
+
+ # Return the list of possibles.
+ return sort @out;
+
+ } ## end if ($text =~ /^[\$@%](.*)::(.*)/)
+
+=pod
+
+=back
+
+=head3 Symbol completion: current package or package C<main>.
+
+=over 4
+
+=cut
+
+
+ if ($text =~ /^[\$@%]/) { # symbols (in $package + packages in main)
+
+=pod
+
+=item * If it's C<main>, delete main to just get C<::> leading.
+
+=cut
+
+ $pack = ($package eq 'main' ? '' : $package) . '::';
+
+=pod
+
+=item * We set the prefix to the item's sigil, and trim off the sigil to get the text to be completed.
+
+=cut
+ $prefix = substr $text, 0, 1;
+ $text = substr $text, 1;
+
+=pod
+
+=item * If the package is C<::> (C<main>), create an empty list; if it's something else, create a list of all the packages known. Append whichever list to a list of all the possible symbols in the current package. C<grep> out the matches to the text entered so far, then C<map> the prefix back onto the symbols.
+
+=cut
+
+ my @out = map "$prefix$_", grep /^\Q$text/,
+ (grep /^_?[a-zA-Z]/, keys %$pack),
+ ($pack eq '::' ? () : (grep /::$/, keys %::));
+
+=item * If there's only one hit, it's a package qualifier, and it's not equal to the initial text, recomplete using this symbol.
+
+=back
+
+=cut
+
+ if (@out == 1 and $out[0] =~ /::$/ and $out[0] ne $itext) {
+ return db_complete($out[0], $line, $start);
+ }
+
+ # Return the list of possibles.
+ return sort @out;
+ } ## end if ($text =~ /^[\$@%]/)
+
+=head3 Options
+
+We use C<option_val()> to look up the current value of the option. If there's
+only a single value, we complete the command in such a way that it is a
+complete command for setting the option in question. If there are multiple
+possible values, we generate a command consisting of the option plus a trailing
+question mark, which, if executed, will list the current value of the option.
+
+=cut
+
+ # Say, didn't the option command's character change?)
+ # XXX Yes it did. Fix the following pattern match to correct the problem.
+ # XXX This is a bug.
+ if ((substr $line, 0, $start) =~ /^\|*O\b.*\s$/) { # Options after a space
+ # We look for the text to be matched in the list of possible options,
+ # and fetch the current value.
+ my @out = grep /^\Q$text/, @options;
+ my $val = option_val($out[0], undef);
+
+ # Set up a 'query option's value' command.
+ my $out = '? ';
+ if (not defined $val or $val =~ /[\n\r]/) {
+ # There's really nothing else we can do.
+ }
+
+ # We have a value. Create a proper option-setting command.
+ elsif ($val =~ /\s/) {
+ # XXX This may be an extraneous variable.
+ my $found;
+
+ # We'll want to quote the string (because of the embedded
+ # whtespace), but we want to make sure we don't end up with
+ # mismatched quote characters. We try several possibilities.
+ foreach $l (split //, qq/\"\'\#\|/) {
+ # If we didn't find this quote character in the value,
+ # quote it using this quote character.
+ $out = "$l$val$l ", last if (index $val, $l) == -1;
+ }
+ } ## end elsif ($val =~ /\s/)
+
+ # Don't need any quotes.
+ else {
+ $out = "=$val ";
+ }
+
+ # If there were multiple possible values, return '? ', which
+ # makes the command into a query command. If there was just one,
+ # have readline append that.
+ $rl_attribs->{completer_terminator_character} =
+ (@out == 1 ? $out : '? ');
+
+ # Return list of possibilities.
+ return sort @out;
+ } ## end if ((substr $line, 0, ...
+
+=head3 Filename completion
+
+For entering filenames. We simply call C<readline>'s C<filename_list()>
+method with the completion text to get the possible completions.
+
+=cut
+
+ return $term->filename_list($text); # filenames
+
+} ## end sub db_complete
+
+=head1 MISCELLANEOUS SUPPORT FUNCTIONS
+
+Functions that possibly ought to be somewhere else.
+
+=head2 end_report
+
+Say we're done.
+
+=cut
sub end_report {
- local $\ = '';
- print $OUT "Use `q' to quit or `R' to restart. `h q' for details.\n"
+ local $\ = '';
+ print $OUT "Use `q' to quit or `R' to restart. `h q' for details.\n";
}
+=head2 clean_ENV
+
+If we have $ini_pids, save it in the environment; else remove it from the
+environment. Used by the C<R> (restart) command.
+
+=cut
+
sub clean_ENV {
if (defined($ini_pids)) {
$ENV{PERLDB_PIDS} = $ini_pids;
- } else {
+ }
+ else {
delete($ENV{PERLDB_PIDS});
}
-}
+} ## end sub clean_ENV
+=head1 END PROCESSING - THE C<END> BLOCK
-# PERLDBf_... flag names from perl.h
-our (%DollarCaretP_flags, %DollarCaretP_flags_r);
-BEGIN {
- %DollarCaretP_flags =
- ( PERLDBf_SUB => 0x01, # Debug sub enter/exit
- PERLDBf_LINE => 0x02, # Keep line #
- PERLDBf_NOOPT => 0x04, # Switch off optimizations
- PERLDBf_INTER => 0x08, # Preserve more data
- PERLDBf_SUBLINE => 0x10, # Keep subr source lines
- PERLDBf_SINGLE => 0x20, # Start with single-step on
- PERLDBf_NONAME => 0x40, # For _SUB: no name of the subr
- PERLDBf_GOTO => 0x80, # Report goto: call DB::goto
- PERLDBf_NAMEEVAL => 0x100, # Informative names for evals
- PERLDBf_NAMEANON => 0x200, # Informative names for anon subs
- PERLDBf_ASSERTION => 0x400, # Debug assertion subs enter/exit
- PERLDB_ALL => 0x33f, # No _NONAME, _GOTO, _ASSERTION
- );
+Come here at the very end of processing. We want to go into a
+loop where we allow the user to enter commands and interact with the
+debugger, but we don't want anything else to execute.
- %DollarCaretP_flags_r=reverse %DollarCaretP_flags;
-}
+First we set the C<$finished> variable, so that some commands that
+shouldn't be run after the end of program quit working.
-sub parse_DollarCaretP_flags {
- my $flags=shift;
- $flags=~s/^\s+//;
- $flags=~s/\s+$//;
- my $acu=0;
- foreach my $f (split /\s*\|\s*/, $flags) {
- my $value;
- if ($f=~/^0x([[:xdigit:]]+)$/) {
- $value=hex $1;
- }
- elsif ($f=~/^(\d+)$/) {
- $value=int $1;
- }
- elsif ($f=~/^DEFAULT$/i) {
- $value=$DollarCaretP_flags{PERLDB_ALL};
- }
- else {
- $f=~/^(?:PERLDBf_)?(.*)$/i;
- $value=$DollarCaretP_flags{'PERLDBf_'.uc($1)};
- unless (defined $value) {
- print $OUT ("Unrecognized \$^P flag '$f'!\n",
- "Acceptable flags are: ".
- join(', ', sort keys %DollarCaretP_flags),
- ", and hexadecimal and decimal numbers.\n");
- return undef;
- }
- }
- $acu|=$value;
- }
- $acu;
-}
+We then figure out whether we're truly done (as in the user entered a C<q>
+command, or we finished exection while running nonstop). If we aren't,
+we set C<$single> to 1 (causing the debugger to get control again).
-sub expand_DollarCaretP_flags {
- my $DollarCaretP=shift;
- my @bits= ( map { my $n=(1<<$_);
- ($DollarCaretP & $n)
- ? ($DollarCaretP_flags_r{$n}
- || sprintf('0x%x', $n))
- : () } 0..31 );
- return @bits ? join('|', @bits) : 0;
-}
+We then call C<DB::fake::at_exit()>, which returns the C<Use 'q' to quit ...">
+message and returns control to the debugger. Repeat.
+
+When the user finally enters a C<q> command, C<$fall_off_end> is set to
+1 and the C<END> block simply exits with C<$single> set to 0 (don't
+break, run to completion.).
+
+=cut
END {
- $finished = 1 if $inhibit_exit; # So that some keys may be disabled.
- $fall_off_end = 1 unless $inhibit_exit;
- # Do not stop in at_exit() and destructors on exit:
- $DB::single = !$fall_off_end && !$runnonstop;
- DB::fake::at_exit() unless $fall_off_end or $runnonstop;
-}
+ $finished = 1 if $inhibit_exit; # So that some commands may be disabled.
+ $fall_off_end = 1 unless $inhibit_exit;
+ # Do not stop in at_exit() and destructors on exit:
+ $DB::single = !$fall_off_end && !$runnonstop;
+ DB::fake::at_exit() unless $fall_off_end or $runnonstop;
+} ## end END
-# ===================================== pre580 ================================
-# this is very sad below here...
-#
+=head1 PRE-5.8 COMMANDS
+
+Some of the commands changed function quite a bit in the 5.8 command
+realignment, so much so that the old code had to be replaced completely.
+Because we wanted to retain the option of being able to go back to the
+former command set, we moved the old code off to this section.
+
+There's an awful lot of duplicated code here. We've duplicated the
+comments to keep things clear.
+
+=head2 Null command
+
+Does nothing. Used to 'turn off' commands.
+
+=cut
sub cmd_pre580_null {
- # do nothing...
+
+ # do nothing...
}
+=head2 Old C<a> command.
+
+This version added actions if you supplied them, and deleted them
+if you didn't.
+
+=cut
+
sub cmd_pre580_a {
- my $xcmd = shift; #
- my $cmd = shift;
- if ($cmd =~ /^(\d*)\s*(.*)/) {
- $i = $1 || $line; $j = $2;
- if (length $j) {
- if ($dbline[$i] == 0) {
- print $OUT "Line $i may not have an action.\n";
- } else {
- $had_breakpoints{$filename} |= 2;
- $dbline{$i} =~ s/\0[^\0]*//;
- $dbline{$i} .= "\0" . action($j);
- }
- } else {
- $dbline{$i} =~ s/\0[^\0]*//;
- delete $dbline{$i} if $dbline{$i} eq '';
- }
- }
-}
+ my $xcmd = shift;
+ my $cmd = shift;
+
+ # Argument supplied. Add the action.
+ if ($cmd =~ /^(\d*)\s*(.*)/) {
+
+ # If the line isn't there, use the current line.
+ $i = $1 || $line;
+ $j = $2;
+
+ # If there is an action ...
+ if (length $j) {
+
+ # ... but the line isn't breakable, skip it.
+ if ($dbline[$i] == 0) {
+ print $OUT "Line $i may not have an action.\n";
+ }
+ else {
+ # ... and the line is breakable:
+ # Mark that there's an action in this file.
+ $had_breakpoints{$filename} |= 2;
+
+ # Delete any current action.
+ $dbline{$i} =~ s/\0[^\0]*//;
+
+ # Add the new action, continuing the line as needed.
+ $dbline{$i} .= "\0" . action($j);
+ }
+ } ## end if (length $j)
+
+ # No action supplied.
+ else {
+ # Delete the action.
+ $dbline{$i} =~ s/\0[^\0]*//;
+ # Mark as having no break or action if nothing's left.
+ delete $dbline{$i} if $dbline{$i} eq '';
+ }
+ } ## end if ($cmd =~ /^(\d*)\s*(.*)/)
+} ## end sub cmd_pre580_a
+
+=head2 Old C<b> command
+
+Add breakpoints.
+
+=cut
sub cmd_pre580_b {
- my $xcmd = shift; #
- my $cmd = shift;
- my $dbline = shift;
- if ($cmd =~ /^load\b\s*(.*)/) {
- my $file = $1; $file =~ s/\s+$//;
- &cmd_b_load($file);
- } elsif ($cmd =~ /^(postpone|compile)\b\s*([':A-Za-z_][':\w]*)\s*(.*)/) {
- my $cond = length $3 ? $3 : '1';
- my ($subname, $break) = ($2, $1 eq 'postpone');
- $subname =~ s/\'/::/g;
- $subname = "${'package'}::" . $subname
- unless $subname =~ /::/;
- $subname = "main".$subname if substr($subname,0,2) eq "::";
- $postponed{$subname} = $break ? "break +0 if $cond" : "compile";
- } elsif ($cmd =~ /^([':A-Za-z_][':\w]*(?:\[.*\])?)\s*(.*)/) {
- my $subname = $1;
- my $cond = length $2 ? $2 : '1';
- &cmd_b_sub($subname, $cond);
- } elsif ($cmd =~ /^(\d*)\s*(.*)/) {
- my $i = $1 || $dbline;
- my $cond = length $2 ? $2 : '1';
- &cmd_b_line($i, $cond);
- }
-}
+ my $xcmd = shift;
+ my $cmd = shift;
+ my $dbline = shift;
+
+ # Break on load.
+ if ($cmd =~ /^load\b\s*(.*)/) {
+ my $file = $1;
+ $file =~ s/\s+$//;
+ &cmd_b_load($file);
+ }
+
+ # b compile|postpone <some sub> [<condition>]
+ # The interpreter actually traps this one for us; we just put the
+ # necessary condition in the %postponed hash.
+ elsif ($cmd =~ /^(postpone|compile)\b\s*([':A-Za-z_][':\w]*)\s*(.*)/) {
+ # Capture the condition if there is one. Make it true if none.
+ my $cond = length $3 ? $3 : '1';
+
+ # Save the sub name and set $break to 1 if $1 was 'postpone', 0
+ # if it was 'compile'.
+ my ($subname, $break) = ($2, $1 eq 'postpone');
+
+ # De-Perl4-ify the name - ' separators to ::.
+ $subname =~ s/\'/::/g;
+
+ # Qualify it into the current package unless it's already qualified.
+ $subname = "${'package'}::" . $subname
+ unless $subname =~ /::/;
+
+ # Add main if it starts with ::.
+ $subname = "main" . $subname if substr($subname, 0, 2) eq "::";
+
+ # Save the break type for this sub.
+ $postponed{$subname} = $break ? "break +0 if $cond" : "compile";
+ } ## end elsif ($cmd =~ ...
+
+ # b <sub name> [<condition>]
+ elsif ($cmd =~ /^([':A-Za-z_][':\w]*(?:\[.*\])?)\s*(.*)/) {
+ my $subname = $1;
+ my $cond = length $2 ? $2 : '1';
+ &cmd_b_sub($subname, $cond);
+ }
+
+ # b <line> [<condition>].
+ elsif ($cmd =~ /^(\d*)\s*(.*)/) {
+ my $i = $1 || $dbline;
+ my $cond = length $2 ? $2 : '1';
+ &cmd_b_line($i, $cond);
+ }
+} ## end sub cmd_pre580_b
+
+=head2 Old C<D> command.
+
+Delete all breakpoints unconditionally.
+
+=cut
sub cmd_pre580_D {
- my $xcmd = shift; #
- my $cmd = shift;
- if ($cmd =~ /^\s*$/) {
- print $OUT "Deleting all breakpoints...\n";
- my $file;
- for $file (keys %had_breakpoints) {
- local *dbline = $main::{'_<' . $file};
- my $max = $#dbline;
- my $was;
-
- for ($i = 1; $i <= $max ; $i++) {
- if (defined $dbline{$i}) {
- $dbline{$i} =~ s/^[^\0]+//;
- if ($dbline{$i} =~ s/^\0?$//) {
- delete $dbline{$i};
- }
- }
- }
-
- if (not $had_breakpoints{$file} &= ~1) {
- delete $had_breakpoints{$file};
- }
- }
- undef %postponed;
- undef %postponed_file;
- undef %break_on_load;
- }
-}
+ my $xcmd = shift;
+ my $cmd = shift;
+ if ($cmd =~ /^\s*$/) {
+ print $OUT "Deleting all breakpoints...\n";
+
+ # %had_breakpoints lists every file that had at least one
+ # breakpoint in it.
+ my $file;
+ for $file (keys %had_breakpoints) {
+ # Switch to the desired file temporarily.
+ local *dbline = $main::{ '_<' . $file };
+
+ my $max = $#dbline;
+ my $was;
+
+ # For all lines in this file ...
+ for ($i = 1 ; $i <= $max ; $i++) {
+ # If there's a breakpoint or action on this line ...
+ if (defined $dbline{$i}) {
+ # ... remove the breakpoint.
+ $dbline{$i} =~ s/^[^\0]+//;
+ if ($dbline{$i} =~ s/^\0?$//) {
+ # Remove the entry altogether if no action is there.
+ delete $dbline{$i};
+ }
+ } ## end if (defined $dbline{$i...
+ } ## end for ($i = 1 ; $i <= $max...
+
+ # If, after we turn off the "there were breakpoints in this file"
+ # bit, the entry in %had_breakpoints for this file is zero,
+ # we should remove this file from the hash.
+ if (not $had_breakpoints{$file} &= ~1) {
+ delete $had_breakpoints{$file};
+ }
+ } ## end for $file (keys %had_breakpoints)
+
+ # Kill off all the other breakpoints that are waiting for files that
+ # haven't been loaded yet.
+ undef %postponed;
+ undef %postponed_file;
+ undef %break_on_load;
+ } ## end if ($cmd =~ /^\s*$/)
+} ## end sub cmd_pre580_D
+
+=head2 Old C<h> command
+
+Print help. Defaults to printing the long-form help; the 5.8 version
+prints the summary by default.
+
+=cut
sub cmd_pre580_h {
- my $xcmd = shift; #
- my $cmd = shift;
- if ($cmd =~ /^\s*$/) {
- print_help($pre580_help);
- } elsif ($cmd =~ /^h\s*/) {
- print_help($pre580_summary);
- } elsif ($cmd =~ /^h\s+(\S.*)$/) {
- my $asked = $1; # for proper errmsg
- my $qasked = quotemeta($asked); # for searching
- # XXX: finds CR but not <CR>
- if ($pre580_help =~ /^<?(?:[IB]<)$qasked/m) {
- while ($pre580_help =~ /^(<?(?:[IB]<)$qasked([\s\S]*?)\n)(?!\s)/mg) {
- print_help($1);
- }
- } else {
- print_help("B<$asked> is not a debugger command.\n");
- }
- }
-}
+ my $xcmd = shift;
+ my $cmd = shift;
+
+ # Print the *right* help, long format.
+ if ($cmd =~ /^\s*$/) {
+ print_help($pre580_help);
+ }
+
+ # 'h h' - explicitly-requested summary.
+ elsif ($cmd =~ /^h\s*/) {
+ print_help($pre580_summary);
+ }
+
+ # Find and print a command's help.
+ elsif ($cmd =~ /^h\s+(\S.*)$/) {
+ my $asked = $1; # for proper errmsg
+ my $qasked = quotemeta($asked); # for searching
+ # XXX: finds CR but not <CR>
+ if ($pre580_help =~ /^
+ <? # Optional '<'
+ (?:[IB]<) # Optional markup
+ $qasked # The command name
+ /mx) {
+
+ while (
+ $pre580_help =~ /^
+ ( # The command help:
+ <? # Optional '<'
+ (?:[IB]<) # Optional markup
+ $qasked # The command name
+ ([\s\S]*?) # Lines starting with tabs
+ \n # Final newline
+ )
+ (?!\s)/mgx) # Line not starting with space
+ # (Next command's help)
+ {
+ print_help($1);
+ }
+ } ## end if ($pre580_help =~ /^<?(?:[IB]<)$qasked/m)
+
+ # Help not found.
+ else {
+ print_help("B<$asked> is not a debugger command.\n");
+ }
+ } ## end elsif ($cmd =~ /^h\s+(\S.*)$/)
+} ## end sub cmd_pre580_h
+
+=head2 Old C<W> command
+
+C<W E<lt>exprE<gt>> adds a watch expression, C<W> deletes them all.
+
+=cut
sub cmd_pre580_W {
- my $xcmd = shift; #
- my $cmd = shift;
- if ($cmd =~ /^$/) {
- $trace &= ~2;
- @to_watch = @old_watch = ();
- } elsif ($cmd =~ /^(.*)/s) {
- push @to_watch, $1;
- $evalarg = $1;
- my ($val) = &eval;
- $val = (defined $val) ? "'$val'" : 'undef' ;
- push @old_watch, $val;
- $trace |= 2;
- }
-}
+ my $xcmd = shift;
+ my $cmd = shift;
+
+ # Delete all watch expressions.
+ if ($cmd =~ /^$/) {
+ # No watching is going on.
+ $trace &= ~2;
+ # Kill all the watch expressions and values.
+ @to_watch = @old_watch = ();
+ }
+
+ # Add a watch expression.
+ elsif ($cmd =~ /^(.*)/s) {
+ # add it to the list to be watched.
+ push @to_watch, $1;
+
+ # Get the current value of the expression.
+ # Doesn't handle expressions returning list values!
+ $evalarg = $1;
+ my ($val) = &eval;
+ $val = (defined $val) ? "'$val'" : 'undef';
+
+ # Save it.
+ push @old_watch, $val;
+
+ # We're watching stuff.
+ $trace |= 2;
+
+ } ## end elsif ($cmd =~ /^(.*)/s)
+} ## end sub cmd_pre580_W
+
+=head1 PRE-AND-POST-PROMPT COMMANDS AND ACTIONS
+
+The debugger used to have a bunch of nearly-identical code to handle
+the pre-and-post-prompt action commands. C<cmd_pre590_prepost> and
+C<cmd_prepost> unify all this into one set of code to handle the
+appropriate actions.
+
+=head2 C<cmd_pre590_prepost>
+
+A small wrapper around C<cmd_prepost>; it makes sure that the default doesn't
+do something destructive. In pre 5.8 debuggers, the default action was to
+delete all the actions.
+
+=cut
sub cmd_pre590_prepost {
- my $cmd = shift;
- my $line = shift || '*'; # delete
- my $dbline = shift;
+ my $cmd = shift;
+ my $line = shift || '*';
+ my $dbline = shift;
- return &cmd_prepost($cmd, $line, $dbline);
-}
+ return &cmd_prepost( $cmd, $line, $dbline );
+} ## end sub cmd_pre590_prepost
-sub cmd_prepost { # cannot do &cmd_<(), <, <<, >>, {, {{, etc.
- my $cmd = shift;
- my $line = shift || '?';
-
- my $which = '';
- my $aref = [];
- if ($cmd =~ /^\</o) {
- $which = 'pre-perl';
- $aref = $pre;
- } elsif ($cmd =~ /^\>/o) {
- $which = 'post-perl';
- $aref = $post;
- } elsif ($cmd =~ /^\{/o) {
- if ($cmd =~ /^\{.*\}$/o && unbalanced(substr($cmd,1))) {
- print $OUT "$cmd is now a debugger command\nuse `;$cmd' if you mean Perl code\n";
- # $DB::cmd = "h $cmd";
- # redo CMD;
- } else {
- $which = 'pre-debugger';
- $aref = $pretype;
- }
- }
-
- unless ($which) {
- print $OUT "Confused by command: $cmd\n";
- } else {
- if ($line =~ /^\s*\?\s*$/o) {
- unless (@$aref) {
- print $OUT "No $which actions.\n";
-# print $OUT "If you meant to delete them all - use '$cmd *' or 'o commandSet=pre590'\n"; # hint
- } else {
- print $OUT "$which commands:\n";
- foreach my $action (@$aref) {
- print $OUT "\t$cmd -- $action\n";
- }
- }
- } else {
- if (length($cmd) == 1) {
- if ($line =~ /^\s*\*\s*$/o) {
- @$aref = (); # delete
- print $OUT "All $cmd actions cleared.\n";
- } else {
- @$aref = action($line); # set
- }
- } elsif (length($cmd) == 2) { # append
- push @$aref, action($line);
- } else {
- print $OUT "Confused by strange length of $which command($cmd)...\n";
- }
- }
- }
-}
+=head2 C<cmd_prepost>
+
+Actually does all the handling foe C<E<lt>>, C<E<gt>>, C<{{>, C<{>, etc.
+Since the lists of actions are all held in arrays that are pointed to by
+references anyway, all we have to do is pick the right array reference and
+then use generic code to all, delete, or list actions.
+
+=cut
+
+sub cmd_prepost { my $cmd = shift;
+
+ # No action supplied defaults to 'list'.
+ my $line = shift || '?';
+
+ # Figure out what to put in the prompt.
+ my $which = '';
+
+ # Make sure we have some array or another to address later.
+ # This means that if ssome reason the tests fail, we won't be
+ # trying to stash actions or delete them from the wrong place.
+ my $aref = [];
+
+ # < - Perl code to run before prompt.
+ if ( $cmd =~ /^\</o ) {
+ $which = 'pre-perl';
+ $aref = $pre;
+ }
+
+ # > - Perl code to run after prompt.
+ elsif ( $cmd =~ /^\>/o ) {
+ $which = 'post-perl';
+ $aref = $post;
+ }
+
+ # { - first check for properly-balanced braces.
+ elsif ( $cmd =~ /^\{/o ) {
+ if ( $cmd =~ /^\{.*\}$/o && unbalanced( substr( $cmd, 1 ) ) ) {
+ print $OUT
+"$cmd is now a debugger command\nuse `;$cmd' if you mean Perl code\n";
+ }
+
+ # Properly balanced. Pre-prompt debugger actions.
+ else {
+ $which = 'pre-debugger';
+ $aref = $pretype;
+ }
+ } ## end elsif ( $cmd =~ /^\{/o )
+
+ # Did we find something that makes sense?
+ unless ($which) {
+ print $OUT "Confused by command: $cmd\n";
+ }
+
+ # Yes.
+ else {
+ # List actions.
+ if ( $line =~ /^\s*\?\s*$/o ) {
+ unless (@$aref) {
+ # Nothing there. Complain.
+ print $OUT "No $which actions.\n";
+ }
+ else {
+ # List the actions in the selected list.
+ print $OUT "$which commands:\n";
+ foreach my $action (@$aref) {
+ print $OUT "\t$cmd -- $action\n";
+ }
+ } ## end else
+ } ## end if ( $line =~ /^\s*\?\s*$/o)
+
+ # Might be a delete.
+ else {
+ if ( length($cmd) == 1 ) {
+ if ( $line =~ /^\s*\*\s*$/o ) {
+ # It's a delete. Get rid of the old actions in the
+ # selected list..
+ @$aref = ();
+ print $OUT "All $cmd actions cleared.\n";
+ }
+ else {
+ # Replace all the actions. (This is a <, >, or {).
+ @$aref = action($line);
+ }
+ } ## end if ( length($cmd) == 1)
+ elsif ( length($cmd) == 2 ) {
+ # Add the action to the line. (This is a <<, >>, or {{).
+ push @$aref, action($line);
+ }
+ else {
+ # <<<, >>>>, {{{{{{ ... something not a command.
+ print $OUT
+ "Confused by strange length of $which command($cmd)...\n";
+ }
+ } ## end else [ if ( $line =~ /^\s*\?\s*$/o)
+ } ## end else
+} ## end sub cmd_prepost
+
+
+=head1 C<DB::fake>
+
+Contains the C<at_exit> routine that the debugger uses to issue the
+C<Debugged program terminated ...> message after the program completes. See
+the C<END> block documentation for more details.
+
+=cut
package DB::fake;
sub at_exit {
- "Debugged program terminated. Use `q' to quit or `R' to restart.";
+ "Debugged program terminated. Use `q' to quit or `R' to restart.";
}
-package DB; # Do not trace this 1; below!
+package DB; # Do not trace this 1; below!
1;
+
projects / p5sagit/p5-mst-13.2.git / commitdiff