From: Jarkko Hietaniemi Date: Tue, 3 Jun 2003 15:51:36 +0000 (+0000) Subject: Urk. Joe's patches were for the maint branch, X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=d12a485175b2df4bc21c0d510c12c134794e6223;p=p5sagit%2Fp5-mst-13.2.git Urk. Joe's patches were for the maint branch, not for the blead (which has assertions and stuff). Retract #19677, #19676, #19674. p4raw-id: //depot/perl@19679 --- diff --git a/lib/perl5db.pl b/lib/perl5db.pl index 855e275..7c8507c 100644 --- a/lib/perl5db.pl +++ b/lib/perl5db.pl @@ -1,682 +1,122 @@ -=head1 NAME - -C - the perl debugger - -=head1 SYNOPSIS - - perl -d your_Perl_script - -=head1 DESCRIPTION - -C is the perl debugger. It is loaded automatically by Perl when -you invoke a script with C. This documentation tries to outline the -structure and services provided by C, 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 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 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 - -As you may recall from reading C, the C 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 -localization, restoring the previous value. Voila, automatic stack management. - -The debugger uses this trick a I. Of particular note is C, -which lets the debugger get control inside of C'ed code. The debugger -localizes a saved copy of C<$@> inside the subroutine, which allows it to -keep C<$@> safe until it C returns, at which point the previous -value of C<$@> is restored. This makes it simple (well, I) to keep -track of C<$@> inside Cs which C other C. - -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 auxiliary variable. For instance, the debugger's C -(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 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. 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 comments for? - -Any comment containing C 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. - -=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 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 starts, it reads an rcfile (C 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 environment variable and treats its -contents as the argument of a debugger command. - -=head2 STARTUP-ONLY OPTIONS - -The following 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. (If you interrupt it, you had better -reset C 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 before the first line. - -After each Cd 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 Cd 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 - -=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 to print return values. - -=head4 C<$evalarg> - -The item to be eval'ed by C. Used to prevent messing with the current -contents of C<@_> when C 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 I=I from I:I>. 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 return from I: I> messages on subroutine/eval exit. Ignored if C<4> is is not on. - -=back - -To get everything, use C<$frame=30> (or C 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 -CE> 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 will print after evaluating an -expression. - -=over 4 - -=item * C - don't print anything - -=item * C - use C to display the value returned - -=item * C - print the methods callable on the first item returned - -=back - -=head4 C<$onetimeDumpDepth> - -Controls how far down C will go before printing '...' while -dumping a structure. Numeric. If C, print all levels. - -=head4 C<$signal> - -Used to track whether or not an C signal has been detected. C, -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 command was entered to turn on tracing (every line executed is printed) - -=item * 2 - watch expressions are active - -=item * 4 - user defined a C in C - -=back - -=head4 C<$slave_editor> - -1 if C was directed to a pipe; 0 otherwise. - -=head4 C<@cmdfhs> - -Stack of filehandles that C will read commands from. -Manipulated by the debugger's C command and C 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 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. - -=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 ' - 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 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 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 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.21; +$VERSION = 1.20; $header = "perl5db.pl version $VERSION"; -=head1 DEBUGGER ROUTINES - -=head2 C - -This function replaces straight C inside the debugger; it simplifies -the process of evaluating code in the user's context. - -The code to be evaluated is passed 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>, X>, and X>; -add the X> (that's the preserved values of C<$@>, C<$!>, -C<$^E>, C<$,>, C<$/>, C<$\>, and C<$^W>, grabbed when C got control, -and the user's current package) and a add a newline before we do the C. -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 will put -C<$@>), and then call C 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 error, we print -it on the debugger's output. If X> is defined, we call -X> if it's set to 'dump', or X> 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 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 isn't parameterized in the standard way; this is to keep the -debugger's calls to C from mucking with C<@_>, among other things. -The variables listed below influence C'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 should go when dumping results - -=back - -The following variables are altered by C during its execution. They -are "stacked" via C, enabling recursive calls to C. - -=over 4 - -=item C<@res> - used to capture output from actual C. - -=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 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 can see localized -variables; and we can't use C either for the same reason. The code -in this routine compromises and uses C. - -After this routine is over, we don't have user code executing in the debugger's -context, so we can use C 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. - +# It is crucial that there is no lexicals in scope of `eval ""' down below sub eval { - # 'my' would make it visible from user code - # but so does local! --tchrist - # Remember: this localizes @DB::res, not @main::res. + # but so does local! --tchrist [... into @DB::res, not @res. IZ] local @res; { - # 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; + 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; } - - # Save the current value of $@, and preserve it in the debugger's copy - # of the saved precious globals. my $at = $@; - - # 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 $@ + 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; + 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]) ; + } } - - # 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. -# The code being debugged will be executing in its own context, and -# can't see the inside of the debugger. +# After this point it is safe to introduce lexicals +# However, one should not overdo it: leave as much control from outside as possible # -# 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. # -# (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.) - +# 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. +# # 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) @@ -685,68 +125,62 @@ sub eval { # Johan Vromans -- upgrade to 4.0 pl 10 # Ilya Zakharevich -- patches after 5.001 (and some before ;-) -# (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 <>, {, {{. +# {dump|print}_trace() coded (to be able to do it from < -# 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 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_*(): +# 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 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_*(): # cmd_b_load($filenamepart) # b load filenamepart # cmd_b_line($lineno [, $cond]) # b lineno [cond] # cmd_b_sub($sub [, $cond]) # b sub [cond] @@ -825,18 +258,16 @@ sub eval { # 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. -# + Low-level debugger API +# j) 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 @@ -871,7 +302,7 @@ sub eval { # + Added *dbline explainatory comments # + Mentioning perldebguts man page # Changes: 1.16: Feb 15, 2002 Mark-Jason Dominus -# + $onetimeDump improvements +# + $onetimeDump improvements # Changes: 1.17: Feb 20, 2002 Richard Foley # Moved some code to cmd_[.]()'s for clarity and ease of handling, # rationalised the following commands and added cmd_wrapper() to @@ -879,8 +310,7 @@ sub eval { # 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) @@ -892,392 +322,182 @@ sub eval { # Changes: 1.20: Feb 17, 2003 Richard Foley # + pre'n'post commands no longer trashed with no args # + watch val joined out of eval() -# Changes: 1.21: Jun 04, 2002 Joe McMahon (mcmahon@ibiblio.org) -# + Added comments and reformatted source. No bug fixes/enhancements. -# + Includes cleanup by Robin Barker and Jarkko Hietaniemi. - +# #################################################################### -=head1 DEBUGGER INITIALIZATION - -The debugger starts up in phases. - -=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 command. - -=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. + +# test if assertions are supported and actived: 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; + $ini_assertion= + eval "sub asserting_test : assertion {1}; 1"; + # $ini_assertion = undef => assertions unsupported, + # " = 1 => assertions suported + # print "\$ini_assertion=$ini_assertion\n"; +} + +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; # 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?! -# 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. +$trace = $signal = $single = 0; # Uninitialized warning suppression + # (local $^W cannot help - other packages!). $inhibit_exit = $option{PrintRet} = 1; -=head1 OPTION PROCESSING - -The debugger's options are actually spread out over the debugger itself and -C; 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 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 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, - ); +@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, + ); -=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 Cd 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 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) - -=back - -=cut + compactDump => 'dumpvar.pl', + veryCompact => 'dumpvar.pl', + quote => 'dumpvar.pl', + ); # 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; - -=pod - -The default C, C, and C handlers are set up. - -=cut +$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; warnLevel($warnLevel); dieLevel($dieLevel); signalLevel($signalLevel); -=pod - -The pager to be used is needed next. We try to get it from the -environment first. if it's not defined there, we try to find it in -the Perl C. If it's not there, we default to C. We -then call the C function to save the pager name. - -=cut - -# This routine makes sure $pager is set up so that '|' can use it. 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 - + defined $ENV{PAGER} ? $ENV{PAGER} : + eval { require Config } && + defined $Config::Config{pager} ? $Config::Config{pager} + : 'more' + ) unless defined $pager; 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; - -=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 - +&shellBang("!") unless defined $psh; 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 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. - -=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}) { - # 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 = $$; +if (defined $ENV{PERLDB_PIDS}) { + $pids = "[$ENV{PERLDB_PIDS}]"; + $ENV{PERLDB_PIDS} .= "->$$"; + $term_pid = -1; +} else { + $ENV{PERLDB_PIDS} = "$$"; + $pids = "{pid=$$}"; + $term_pid = $$; } - $pidprompt = ''; +*emacs = $slave_editor if $slave_editor; # May be used in afterinit()... -# 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. - -=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"; +if (-e "/dev/tty") { # this is the wrong metric! + $rcfile=".perldb"; +} else { + $rcfile="perldb.ini"; } -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 unfortunate at best. -sub safe_do { +# your lexical scope, which is unfortunately 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 < command is invoked, it -tries to capture all of the state it can into environment variables, and -then sets C. When we start executing again, we check to see -if C 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 +# Here begin the unreadable code. It needs fixing. if (exists $ENV{PERLDB_RESTART}) { - # 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 + 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); +} if ($notty) { - $runnonstop = 1; + $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"; + } + } } -=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 instead of a separate device. - -=cut - - - if ($^O eq 'cygwin') { - # /dev/tty is binary. use stdin for textmode - undef $console; - } - -=item * Unix - use C. - -=cut - - elsif (-e "/dev/tty") { - $console = "/dev/tty"; - } - -=item * Windows or MSDOS - use C. - -=cut - - elsif ($^O eq 'dos' or -e "con" or $^O eq 'MSWin32') { - $console = "con"; - } - -=item * MacOS - use C if this is the MPW version; C 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. - -=cut - - else { - # everything else is ... - $console = "sys\$command"; - } - -=pod - -=back - -Several other systems don't use a specific console. We C -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 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 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 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 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(); +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++) { - # 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. + 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. &save; - - # 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($package, $filename, $line) = caller; local $filename_ini = $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 }; + local $usercontext = '($@, $!, $^E, $,, $/, $\, $^W) = @saved;' . + "package $package;"; # this won't let them modify, alas + 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 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. + 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/; + } + } 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; # 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 < - -C is a function that can be defined by the user; it is a -function which will be run on each entry to C; 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 can control the debugger's actions. Any of the following -will cause the debugger to return control to the user's program after -C executes: - -=over 4 - -=item * Returning a false value from the C 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. 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. + $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); + } $was_signal = $signal; - $signal = 0; - -=head2 GETTING READY TO EXECUTE COMMANDS - -The debugger decides to take control if single-step mode is on, the -C 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). + $signal = 0; if ($single || ($trace & 1) || $was_signal) { - # 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, we've gone through the -C 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(< to quit or B to restart, use B I to avoid stopping after program termination, B, B or B to get additional info. EOP - - # 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. + $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); + } + } + } + } $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) { - # Yes, go down a level. - local $level = $level + 1; + 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}) =~ ss\a$k\a(.*)\a$1) { + 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; + (); +} - # Do any pre-prompt actions. - foreach $evalarg (@$pre) { - &eval; - } +# The following code may be executed now: +# BEGIN {warn 4} - # Complain about too much recursion if we passed the limit. - print $OUT $stack_depth . " levels deep in subroutine calls!\n" - if $single & 4; +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; + } +} - # 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. +### The API section - # Tack preprompt debugger actions ahead of any actual input. - @typeahead = (@$pretype, @typeahead); +### 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', + }, +); -=head2 WHERE ARE WE? +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); +} -XXX Relocate this section? +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 + } +} -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 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 + } +} -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 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<$start> is the "current" line. It is used for things like knowing where to -move forwards or backwards from when doing an C or C<-> command. +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<$max> tells the debugger where the last line of the current file is. It's -used to terminate loops most often. +sub break_on_load { + my $file = shift; + $break_on_load{$file} = 1; + $had_breakpoints{$file} |= 1; +} -=head2 THE COMMAND LOOP +sub report_break_on_load { + sort keys %break_on_load; +} -Most of C is actually a command parsing and dispatch loop. It comes -in two parts: +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"; +} -=over 4 +$filename_error = ''; -=item * The outer part of the loop, starting at the C label. This loop -reads a command and then executes it. +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 inner part of the loop, starting at the C label. This part -is wholly contained inside the C block and only executes a command. -Used to handle commands running inside a pager. +sub breakable_line_in_filename { + my ($f) = shift; + local *dbline = $main::{'_<' . $f}; + local $filename_error = " of `$f'"; + breakable_line(@_); +} -=back +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; } +} -So why have two labels to restart the loop? Because sometimes, it's easier to -have a command I another command and then re-execute the loop to do -the new command. This is faster, but perhaps a bit more convoluted. +sub cmd_b_line { + eval { break_on_line(@_); 1 } or do { + local $\ = ''; + print $OUT $@ and return; + }; +} -=cut +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); +} - # 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 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); +} - # Don't stop running. - $single = 0; +sub subroutine_filename_lines { + my ($subname,$cond) = @_; + # Filename below can contain ':' + find_sub($subname) =~ /^(.*):(\d+)-(\d+)$/; +} - # No signal is active. - $signal = 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,@_); +} - # Handle continued commands (ending with \): - $cmd =~ s/\\$/\n/ && do { - $cmd .= &readline(" cont: "); - redo CMD; - }; +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; + } +} -=head4 The null command +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 + } +} -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 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; + } +} -=cut +sub cmd_stop { # As on ^C, but not signal-safy. + $signal = 1; +} - # Empty input means repeat the last command. - $cmd =~ /^$/ && ($cmd = $laststep); - push (@hist, $cmd) if length($cmd) > 1; +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 for example + my $asked = $1; # for proper errmsg + my $qasked = quotemeta($asked); # for searching + # XXX: finds CR but not + if ($help =~ /^ is not a debugger command.\n"); + } + } else { + print_help($summary); + } +} +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; + } +} - # 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_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; + } + } + } +} -=head3 COMMAND ALIASES +sub cmd_M { + &list_modules(); +} -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 +sub cmd_o { + my $cmd = shift; # o + my $opt = shift || ''; # opt[=val] + if ($opt =~ /^(\S.*)/) { + &parse_options($1); + } else { + for (@options) { + &dump_option($_); + } + } +} - # 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__}; +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"; # +} - # 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}) +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); + } +} -=head3 MAIN-LINE COMMANDS +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 + } +} -All of these commands work up to and after the program being debugged has -terminated. +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 + } +} -=head4 C - 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 +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 } + } + # else { print $OUT "undefined acu\n" } + } + my $expanded=expand_DollarCaretP_flags($^P); + print $OUT "Internal Perl debugger flags:\n\$^P=$expanded\n"; + $expanded +} - $cmd =~ /^q$/ && do { - $fall_off_end = 1; - clean_ENV(); - exit $?; - }; +### END of the API section -=head4 C - trace +sub save { + @saved = ($@, $!, $^E, $,, $/, $\, $^W); + $, = ""; $/ = "\n"; $\ = ""; $^W = 0; +} -Turn tracing on or off. Inverts the appropriate bit in C<$trace> (q.v.). +sub print_lineinfo { + resetterm(1) if $LINEINFO eq $OUT and $term_pid != $$; + local $\ = ''; + local $, = ''; + print $LINEINFO @_; +} -=cut +# The following takes its argument via $evalarg to preserve current @_ - $cmd =~ /^t$/ && do { - $trace ^= 1; - local $\ = ''; - print $OUT "Trace = " . (($trace & 1) ? "on" : "off") . - "\n"; - next CMD; - }; +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"; +} -=head4 C - list subroutines matching/not matching a pattern +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/^_, checking to see whether or not to print the name. +sub dumpit { + local ($savout) = select(shift); + my $osingle = $single; + my $otrace = $trace; + $single = $trace = 0; + local $frame = 0; + local $doret = -2; + unless (defined &main::dumpValue) { + do 'dumpvar.pl'; + } + 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 { + local $\ = ''; + print $OUT "dumpvar.pl not available.\n"; + } + $single = $osingle; + $trace = $otrace; + select ($savout); +} -=cut +# Tied method do not create a context, so may get wrong message: - $cmd =~ /^S(\s+(!)?(.+))?$/ && do { +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"; + } + } +} - $Srev = defined $2; # Reverse scan? - $Spatt = $3; # The pattern (if any) to use. - $Snocheck = !defined $1; # No args - print all subs. +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; +} - # 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; - }; +sub action { + my $action = shift; + while ($action =~ s/\\$//) { + #print $OUT "+ "; + #$action .= "\n"; + $action .= &gets; + } + $action; +} -=head4 C - list variables in current package +sub unbalanced { + # i hate using globals! + $balanced_brace_re ||= qr{ + ^ \{ + (?: + (?> [^{}] + ) # Non-parens without backtracking + | + (??{ $balanced_brace_re }) # Group with matching parens + ) * + \} $ + }x; + return $_[0] !~ m/$balanced_brace_re/; +} -Since the C command actually processes this, just change this to the -appropriate C command and fall through. +sub gets { + &readline("cont: "); +} -=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"); - $cmd =~ s/^X\b/V $package/; + # 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); + close(SAVEOUT); -=head4 C - list variables -Uses C to dump out the current values for selected variables. + # 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"); + } -=cut + return $?; - # Bare V commands get the currently-being-debugged package - # added. - $cmd =~ /^V$/ && do { - $cmd = "V $package"; - }; +} +sub setterm { + local $frame = 0; + local $doret = -2; + eval { require Term::ReadLine } or die $@; + 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 (!$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; + $lineinfo = $console unless defined $lineinfo; + $term->MinLine(2); + if ($term->Features->{setHistory} and "@hist" ne "?") { + $term->SetHistory(@hist); + } + ornaments($ornaments) if defined $ornaments; + $term_pid = $$; +} - # 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; - }; +# 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;\ + sleep 10000000' |]; + my $tty = ; + chomp $tty; + $pidprompt = ''; # Shown anyway in titlebar + return $tty; +} -=head4 C - evaluate and print an expression +# 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 +END {sleep 5 unless $loaded} +BEGIN {open STDIN, ', setting it up to print the value -via C instead of just printing it directly. +my ($rl, $in) = (shift, shift); # Read from $in and pass through +set_title pop; +system P_NOWAIT, $^X, '-we', <&=$out" or die "Cannot open &=$out for writing: $!"; +select OUT; $| = 1; +require Term::ReadKey if $rl; +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; +} - $cmd =~ s/^x\b/ / && do { # Remainder gets done by DB::eval() - $onetimeDump = 'dump'; # main::dumpvar shows the output +sub create_IN_OUT { # Create a window with IN/OUT handles redirected there + my $in = &get_fork_TTY if defined &get_fork_TTY; + $in = $fork_TTY if defined $fork_TTY; # Backward compatibility + if (not defined $in) { + my $why = shift; + print_help(< Forked, but do not know how to create a new B. I<#########> +EOP + print_help(< Daughter session, do not know how to change a B. I<#########> + This may be an asynchronous session, so the parent debugger may be active. +EOP + print_help(< + in B<\$DB::fork_TTY>, or define a function B returning this. -=head4 C - print methods + On I-like systems one can get the name of a I for the given window + by typing B, and disconnect the I from I by B. -Just uses C to determine what methods are available. +EOP + } elsif ($in ne '') { + TTY($in); + } else { + $console = ''; # Indicate no need to open-from-the-console + } + undef $fork_TTY; +} -=cut +sub resetterm { # We forked, so we need a different TTY + my $in = shift; + my $systemed = $in > 1 ? '-' : ''; + if ($pids) { + $pids =~ s/\]/$systemed->$$]/; + } else { + $pids = "[$term_pid->$$]"; + } + $pidprompt = $pids; + $term_pid = $$; + return unless $CreateTTY & $in; + create_IN_OUT($in); +} - $cmd =~ s/^m\s+([\w:]+)\s*$/ / && do { - methods($1); - next CMD; - }; +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(@_); + } +} - # 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 - }; +sub dump_option { + my ($opt, $val)= @_; + $val = option_val($opt,'N/A'); + $val =~ s/([\\\'])/\\$1/g; + printf $OUT "%20s = '%s'\n", $opt, $val; +} -=head4 C - 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; - } - }; +sub options2remember { + foreach my $k (@RememberOnROptions) { + $option{$k}=option_val($k, 'N/A'); + } + return %option; +} -=head4 C<.> - return to last-executed line. +sub option_val { + 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}; + } + $val = $default unless defined $val; + $val +} -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. +sub parse_options { + 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 + }; + 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 $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." + 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; + } +} -=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; + } +} - # . command. - $cmd =~ /^\.$/ && do { - $incr = -1; # stay at current line +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; +} - # Reset everything to the old location. - $start = $line; - $filename = $filename_ini; - *dbline = $main::{ '_<' . $filename }; - $max = $#dbline; +sub catch { + $signal = 1; + return; # Put nothing on the stack - malloc/free land! +} - # Now where are we? - print_lineinfo($position); - next CMD; - }; +sub warn { + my($msg)= join("",@_); + $msg .= ": $!\n" unless $msg =~ /\n$/; + local $\ = ''; + print $OUT $msg; +} -=head4 C<-> - back one window +sub reset_IN_OUT { + my $switch_li = $LINEINFO eq $OUT; + 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); + } + my $o = select $OUT; + $| = 1; + select $o; + $LINEINFO = $OUT if $switch_li; +} -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 (list one window from -C<$start>) in C<$cmd> to be executed later. +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; + } + &warn("Too late to set TTY, enabled on next `R'!\n") if $term and @_; + # Useful if done through PERLDB_OPTS: + $console = $tty = shift if @_; + $tty or $console; +} -=cut +sub noTTY { + if ($term) { + &warn("Too late to set noTTY, enabled on next `R'!\n") if @_; + } + $notty = shift if @_; + $notty; +} - # - - 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; +sub ReadLine { + if ($term) { + &warn("Too late to set ReadLine, enabled on next `R'!\n") if @_; + } + $rl = shift if @_; + $rl; +} - # Generate and execute a "l +" command (handled below). - $cmd = 'l ' . ($start) . '+'; - }; +sub RemotePort { + if ($term) { + &warn("Too late to set RemotePort, enabled on next 'R'!\n") if @_; + } + $remoteport = shift if @_; + $remoteport; +} -=head3 PRE-580 COMMANDS VS. NEW COMMANDS: C, EE, {, {{> +sub tkRunning { + if (${$term->Features}{tkRunning}) { + return $term->tkRunning(@_); + } else { + local $\ = ''; + print $OUT "tkRunning not supported by current ReadLine package.\n"; + 0; + } +} -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 to -deal with them instead of processing them in-line. +sub NonStop { + if ($term) { + &warn("Too late to set up NonStop mode, enabled on next `R'!\n") if @_; + } + $runnonstop = shift if @_; + $runnonstop; +} -=cut +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) +} - # 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; - }; +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; +} -=head4 C - List lexicals in higher scope +sub pager { + if (@_) { + $pager = shift; + $pager="|".$pager unless $pager =~ /^(\+?\>|\|)/; + } + $pager; +} -Uses C to find the lexicals supplied as arguments in a scope -above the current one and then displays then using C. +sub shellBang { + if (@_) { + $sh = quotemeta shift; + $sh .= "\\b" if $sh =~ /\w$/; + } + $psh = $sh; + $psh =~ s/\\b$//; + $psh =~ s/\\(.)/$1/g; + $psh; +} -=cut +sub ornaments { + if (defined $term) { + local ($warnLevel,$dieLevel) = (0, 1); + return '' unless $term->Features->{ornaments}; + eval { $term->ornaments(@_) } || ''; + } else { + $ornaments = shift; + } +} - $cmd =~ /^y(?:\s+(\d*)\s*(.*))?$/ && do { +sub recallCommand { + if (@_) { + $rc = quotemeta shift; + $rc .= "\\b" if $rc =~ /\w$/; + } + $prc = $rc; + $prc =~ s/\\b$//; + $prc =~ s/\\(.)/$1/g; + $prc; +} - # 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 - 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). We also save the C 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 - single-step, entering subs - -Sets C<$single> to 1, which causes X to continue tracing inside -subs. Also saves C 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 - 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 - return from a subroutine - -For C 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 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 - 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 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. - -=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 it. The debugger will spot the C -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 - stack trace - -Just calls C. - -=cut - - $cmd =~ /^T$/ && do { - print_trace($OUT, 1); # skip DB - next CMD; - }; - -=head4 C - List window around current line. - -Just calls C. - -=cut - - $cmd =~ /^w\b\s*(.*)/s && do { &cmd_w('w', $1); next CMD; }; - -=head4 C - watch-expression processing. - -Just calls C. - -=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 it and exit. -If not, we create some code to do the search and C 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 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 command - -Calls the C to handle the command. This keeps the C and -C 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 $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 . - -=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 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> - Force execution of a command in a shell - -Like the above, but the command is passed to the shell. Again, we use -C to avoid problems with C and C. - -=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 - 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 - look up documentation - -Just calls C 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

- print - -Builds a C 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}) =~ ss\a$k\a(.*)\a$1) { - # 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 - read commands from a file. - -Opens a lexical filehandle and stacks it on C<@cmdfhs>; C 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 (the debugger's output filehandle) and C -(the program's standard output). For C<||>, we only save C. 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 handler which will simply -set C<$signal>, sending us back into the debugger. - -We then trim off the pipe symbols and C the command loop at the -C 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 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 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 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 to get called -again, repeating until the subroutine ends and returns control to C -again. Once control returns, C 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 hadn't been there at all. - -C 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 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 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 support - -If C is called from the package C, 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(). - -=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() text, if any (undefined for C) - -=item * C<$is_require> - -frame was created by a C or C 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 -on error; the rest simply return a false value. - -The user-interface functions (all of the C 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 (API) - -C allows the debugger to switch command sets -depending on the value of the C option. - -It tries to look up the command in the X> package-level I -(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 -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 (command) - -The C 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 (command) - -Delete actions. Similar to above, except the delete code is in a separate -subroutine, C. - -=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 (API) - -C accepts either a line number or C. 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 (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 [] - # 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 [] - elsif ($line =~ /^([':A-Za-z_][':\w]*(?:\[.*\])?)\s*(.*)/) { - # - $subname = $1; - $cond = length $2 ? $2 : '1'; - &cmd_b_sub($subname, $cond); - } - - # b []. - 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 (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 (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 (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 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 * Localizes 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 and C for more -details. - -=back - -=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 C<$to> that's breakable, if there is one. - -If C<$from> is greater than C<$to>, the search goes I, finding the -first line I 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, 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 condition (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. 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 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 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 to find the subroutine, and -C 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 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 - 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 to actually do the work. - -If C<*> is specified, C calls C 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 - 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 '. 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 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 - - # Search the help string for the command. - if ($help =~ /^ # Start of a line - 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 - 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> for current line, -C for break on this line, C 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 - 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'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 - list modules (command) - -Just call C. - -=cut - -sub cmd_M { - &list_modules(); -} - -=head3 C - options (command) - -If this is just C by itself, we list the current settings via -C. If there's a nonblank value following it, we pass that on to -C for processing. - -=cut - -sub cmd_o { - 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 - 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"; # -} - -=head3 C - view window (command) - -Uses the C<$preview> variable set in the second C block (q.v.) to -move back a few lines to list the selected line in context. Uses C -to do the actual listing after figuring 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); - - # List the lines. - &cmd_l('l', $line); - } ## end if ($line =~ /^(\d*)$/) -} ## end sub cmd_v - -=head3 C - 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; - - # 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 - 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; - my $expr = shift || ''; - - # Delete them all. - if ($expr eq '*') { - # Not watching now. - $trace &= ~2; - - print $OUT "Deleting all watch expressions ...\n"; - - # And all gone. - @to_watch = @old_watch = (); - } - - # 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); - - $, = ""; # 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 - 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 { - # 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 - -Handles setting postponed breakpoints in subroutines once they're compiled. -For breakpoints, we use C 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 { - # Get the subroutine name. - my $subname = shift; - - # If this is a 'break + if ' ... - 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 '+' 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 - -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, C, -etc.) into the just-compiled code. - -If this is a C'd file, the incoming parameter is the glob -C<*{"_<$filename"}>, with C<$filename> the name of the C'd file. - -If it's a subroutine, the incoming parameter is the subroutine name. - -=cut - -sub postponed { - # 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/^_ - -C is the debugger's wrapper around dumpvar.pl. - -It gets a filehandle (to which C'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 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 (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 then checks to see if it needs to load C and -tries to load it (note: if you have a C ahead of the -installed version in @INC, yours will be used instead. Possible security -problem?). - -It then checks to see if the subroutine C is now defined -(it should have been defined by C). If it has, C -localizes the globals necessary for things to be sane when C -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 -specified. If not, -1 is assumed; if so, the supplied value gets passed on to -C. This tells C where to leave off when dumping a -structure: -1 means dump everything. - -C is then called if possible; if not, Cjust 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; - $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'; - } - - # 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); - } ## end if (defined &main::dumpValue) - - # Oops, couldn't load dumpvar.pl. - else { - local $\ = ''; - print $OUT "dumpvar.pl not available.\n"; - } - - # Reset $single and $trace to their old values. - $single = $osingle; - $trace = $otrace; - - # Restore the old filehandle. - select($savout); -} ## end sub dumpit - -=head2 C - -C's job is to print a stack trace. It does this via the -C routine, which actually does all the ferreting-out of the -stack trace data. C 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; - # 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. It does -some filtering and cleanup of the data, but mostly it just collects it to -make C's job easier. - -C defines the number of stack frames to be skipped, working backwards -from the most current. C determines the total number of frames to -be returned; all of them (well, the first 10^9) are returned if C -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 - C<.> (null), C<$> (scalar), or C<@> (array) - -=item * C - subroutine name, or C information - -=item * C - undef, or a reference to an array of arguments - -=item * C - the file in which this item was defined (if any) - -=item * C - the line on which it was defined - -=back - -=cut - -sub dump_trace { - - # 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 - -C 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 trailing backslash. - -=cut - -sub action { - my $action = shift; - - while ($action =~ s/\\$//) { - # 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 - -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 - ) * - \} $ - }x; - return $_[0] !~ m/$balanced_brace_re/; -} ## end sub unbalanced - -=head2 C - -C is a primitive (very primitive) routine to read continuations. -It was devised for reading continuations for actions. -it just reads more input with X> and returns it. - -=cut - -sub gets { - &readline("cont: "); -} - -=head2 C - handle calls to without messing up the debugger - -The C 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 socks away the program's STDIN and STDOUT, and then substitutes -the debugger's IN and OUT filehandles for them. It does the C 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"); - - # 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); - 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" - ); - } ## 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 debugger option was set, we'll either use the terminal -supplied (the value of the C option), or we'll use C -to find one. If we're a forked debugger, we call C to try to -get a whole new terminal if we can. - -In either case, we set up the terminal next. If the C option was -true, we'll get a C 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); - } ## 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; - } - - # 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); - } - - # 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 which starts a new debugger, we need to be able to get a new -C and C 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 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 functions which work for X Windows and -OS/2. Other systems are not supported. You are encouraged to write -C functions which work for I platform and contribute them. - -=head3 C - -This function provides the C function for X windows. If a -program running under the debugger forks, a new window is opened and -the subsidiary debugger is directed there. - -The C call is of particular note here. We have the new C -we're spawning route file number 3 to STDOUT, and then execute the C -command (which prints the device name of the TTY we'll want to use for input -and output to STDOUT, then C for a very long time, routing this output -to file number 3. This way we can simply read from the filehandle (which -is STDOUT from the I we ran) to get the TTY we want to use. - -Only works if C is in your path and C<$ENV{DISPLAY}>, etc. are -properly set up. - -=cut - -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;\ - sleep 10000000' |]; - - # Get the output from 'tty' and clean it up a little. - my $tty = ; - chomp $tty; - - $pidprompt = ''; # Shown anyway in titlebar - - # There's our new TTY. - return $tty; -} ## end sub xterm_get_fork_TTY - -=head3 C - -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 -END {sleep 5 unless $loaded} -BEGIN {open STDIN, '&=$out" or die "Cannot open &=$out for writing: $!"; -select OUT; $| = 1; -require Term::ReadKey if $rl; -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 - } ## end if (pipe $in1, $out1 and... - return; -} ## end sub os2_get_fork_TTY - -=head2 C - -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. - -=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; - - # It used to be that - $in = $fork_TTY if defined $fork_TTY; # Backward compatibility - - if (not defined $in) { - my $why = shift; - - # We don't know how. - print_help(< Forked, but do not know how to create a new B. I<#########> -EOP - - # Forked debugger. - print_help(< Daughter session, do not know how to change a B. I<#########> - This may be an asynchronous session, so the parent debugger may be active. -EOP - - # Note that both debuggers are fighting over the same input. - print_help(< - in B<\$DB::fork_TTY>, or define a function B returning this. - - On I-like systems one can get the name of a I for the given window - by typing B, and disconnect the I from I by B. - -EOP - } ## 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 - -Handles rejiggering the prompt when we've forked off a new debugger. - -If the new debugger happened because of a C that invoked a -program under the debugger, the arrow between the old pid and the new -in the prompt has I dashes instead of one. - -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 is off, or C 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->$$]/; - } - - # No pid list. Time to make one. - else { - $pids = "[$term_pid->$$]"; - } - - # The prompt we're going to be using for this debugger. - $pidprompt = $pids; - - # 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 - -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 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 - -=head1 OPTIONS SUPPORT ROUTINES - -These routines handle listing and setting option values. - -=head2 C - list the current value of an option setting - -This routine uses C 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'); - $val =~ s/([\\\'])/\\$1/g; - printf $OUT "%20s = '%s'\n", $opt, $val; -} ## end sub dump_option - -=head2 C - 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 $val; - - # 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; -} ## end sub option_val - -=head2 C - -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 $\ = ''; - - # 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; - - # 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; - } - - # 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." - 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; - - # 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; -} ## end sub get_list - -=head1 MISCELLANEOUS SIGNAL AND I/O MANAGEMENT - -=head2 catch() - -The C 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! -} - -=head2 C - -C emits a warning, by joining together its arguments and printing -them, with couple of fillips. - -If the composited message I 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 ("", @_); - $msg .= ": $!\n" unless $msg =~ /\n$/; - local $\ = ''; - print $OUT $msg; -} ## end sub warn - -=head1 INITIALIZATION TTY SUPPORT - -=head2 C - -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); - } - - # 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 - -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 information 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}) { - # 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 - -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 @_; - } - $notty = shift if @_; - $notty; -} ## end sub noTTY - -=head2 C - -Sets the C<$rl> option variable. If 0, we use C -(essentially, no C processing on this "terminal"). Otherwise, we -use C. 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 @_; - } - $rl = shift if @_; - $rl; -} ## end sub ReadLine - -=head2 C - -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) { - &warn("Too late to set RemotePort, enabled on next 'R'!\n") if @_; - } - $remoteport = shift if @_; - $remoteport; -} ## end sub RemotePort - -=head2 C - -Checks with the terminal to see if C is running, and returns true or -false. Returns false if the current terminal doesn't support C. - -=cut - -sub tkRunning { - if (${ $term->Features }{tkRunning}) { - return $term->tkRunning(@_); - } - else { - local $\ = ''; - print $OUT "tkRunning not supported by current ReadLine package.\n"; - 0; - } -} ## end sub tkRunning - -=head2 C - -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 @_; - } - $runnonstop = shift if @_; - $runnonstop; -} ## end sub NonStop - -=head2 C - -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; -} ## end sub pager - -=head2 C - -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$/; - } - - # 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 - -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) { - # 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 - -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$/; - } - - # 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 - 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 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 - -=head1 COMMAND SUPPORT ROUTINES - -These subroutines provide functionality for various commands. - -=head2 C - -For the C 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 - -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 'ornaments' -(BEE, IEE) 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 BEE -and IEE), 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. 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 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 Stack trace. -B [I] Single step [in I]. -B [I] Next, steps over subroutine calls [in I]. -> Repeat last B or B command. -B Return from current subroutine. -B [I|I] Continue; optionally inserts a one-time-only breakpoint - at the specified position. -B IB<+>I List I+1 lines starting at I. -B IB<->I List lines I through I. -B I List single I. -B I List first window of lines from subroutine. -B I<\$var> List first window of lines from subroutine referenced by I<\$var>. -B List next window of lines. -B<-> List previous window of lines. -B [I] View window around I. -B<.> Return to the executed line. -B I Switch to viewing I. File must be already loaded. - I may be either the full name of the file, or a regular - expression matching the full file name: - B I and B I may access the same file. - Evals (with saved bodies) are considered to be filenames: - B I<(eval 7)> and B I access the body of the 7th eval - (in the order of execution). -BIB Search forwards for I; final B is optional. -BIB Search backwards for I; final B is optional. -B [I] List actions and or breakpoints and or watch-expressions. -B [[B]I] List subroutine names [not] matching I. -B Toggle trace mode. -B I Trace through execution of I. -B Sets breakpoint on current line) -B [I] [I] - Set breakpoint; I defaults to the current execution line; - I breaks if it evaluates to true, defaults to '1'. -B I [I] - Set breakpoint at first line of subroutine. -B I<\$var> Set breakpoint at first line of subroutine referenced by I<\$var>. -B B I Set breakpoint on 'require'ing the given file. -B B I [I] - Set breakpoint at first line of subroutine after - it is compiled. -B B I - Stop after the subroutine is compiled. -B [I] Delete the breakpoint for I. -B I<*> Delete all breakpoints. -B [I] I - Set an action to be done before the I is executed; - I defaults to the current execution line. - Sequence is: check for breakpoint/watchpoint, print line - if necessary, do action, prompt user if necessary, - execute line. -B Does nothing -B [I] Delete the action for I. -B I<*> Delete all actions. -B I Add a global watch-expression. -B Does nothing -B I Delete a global watch-expression. -B I<*> Delete all watch-expressions. -B [I [I]] List some (default all) variables in package (default current). - Use B<~>I and BI for positive and negative regexps. -B [I] Same as \"B I [I]\". -B I Evals expression in list context, dumps the result. -B I Evals expression in list context, prints methods callable - on the first element of the result. -B I Prints methods callable via the given class. -B Show versions of loaded modules. -B [I [I]] List lexicals in higher scope . Vars same as B. - -B<<> ? List Perl commands to run before each prompt. -B<<> I Define Perl command to run before each prompt. -B<<<> I 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<>> ? List Perl commands to run after each prompt. -B<>> I Define Perl command to run after each prompt. -B<>>B<>> I 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<{> I 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 Add to the list of debugger commands to run before each prompt. -B<$prc> I Redo a previous command (default previous command). -B<$prc> I<-number> Redo number'th-to-last command. -B<$prc> I Redo last command that started with I. - See 'B I' too. -B<$psh$psh> I Run cmd in a subprocess (reads from DB::IN, writes to DB::OUT)" - . ( - $rc eq $sh - ? "" - : " -B<$psh> [I] Run I in subshell (forces \"\$SHELL -c 'cmd'\")." - ) - . " - See 'B I' too. -B I Execute I containing debugger commands (may nest). -B I<-number> Display last number commands (default all). -B

I Same as \"I\" in current package. -B<|>I Run debugger command, piping DB::OUT to current pager. -B<||>I Same as B<|>I but DB::OUT is temporarilly select()ed as well. -B<\=> [I I] Define a command alias, or list current aliases. -I Execute as a perl statement in current package. -B Pure-man-restart of debugger, some of debugger state - and command-line options may be lost. - Currently the following settings are preserved: - history, breakpoints and actions, debugger Bptions - and the following command-line options: I<-w>, I<-I>, I<-e>. - -B [I] ... Set boolean option to true -B [IB] Query options -B [IB<=>I] [I=B<\">IB<\">] ... - Set options. Use quotes in spaces in value. - I, I chars used to recall command or spawn shell; - I program for output of \"|cmd\"; - I run Tk while prompting (with ReadLine); - I I I level of verbosity; - I Allows stepping off the end of the script. - I Debugger should stop as early as possible. - I Remote hostname:port for remote debugging - The following options affect what happens with B, B, and B commands: - I, I print only first N elements ('' for all); - I, I change style of array and hash dump; - I whether to print contents of globs; - I dump arrays holding debugged files; - I dump symbol tables of packages; - I dump contents of \"reused\" addresses; - I, I, I change style of string dump; - I Do not print the overload-stringified value; - Other options include: - I affects printing of return value after B command, - I affects printing messages on subroutine entry/exit. - I affects printing messages on possible breaking points. - I gives max length of evals/args listed in stack trace. - I affects screen appearance of the command line. - I bits control attempts to create a new TTY on events: - 1: on fork() 2: debugger is started inside debugger - 4: on startup - During startup options are initialized from \$ENV{PERLDB_OPTS}. - You can put additional initialization options I, I, - I, I, and I there (or use - `B' after you set them). - -B or B<^D> Quit. Set B<\$DB::finished = 0> to debug global destruction. -B Summary of debugger commands. -B [I] Get help [on a specific debugger command], enter B<|h> to page. -B Long help for debugger commands -B<$doccmd> I Runs the external doc viewer B<$doccmd> command on the - named Perl I, or on B<$doccmd> itself if omitted. - Set B<\$DB::doccmd> to change viewer. - -Type `|h h' for a paged display if this was too hard to read. - -"; # Fix balance of vi % matching: }}}} - - # note: tabs in the following section are not-so-helpful - $summary = <<"END_SUM"; -I I - B [I|I] List source code B Stack trace - B<-> or B<.> List previous/current line B [I] Single step [in expr] - B [I] View around line B [I] Next, steps over subs - B I View source in file /B> Repeat last B or B - BIB BIB Search forw/backw B Return from subroutine - B Show module versions B [I|I] Continue until position -I B List break/watch/actions - B [...] Set debugger options B [I] Toggle trace [trace expr] - B<<>[B<<>]|B<{>[B<{>]|B<>>[B<>>] [I] Do pre/post-prompt B [I|I|I] [I] Set breakpoint - B<$prc> [I|I] Redo a previous command B I Delete a/all breakpoints - B [I<-num>] Display last num commands B [I] I Do cmd before line - B<=> [I I] Define/list an alias B I Delete a/all actions - B [I] Get help on command B I Add a watch expression - B Complete help page B I Delete a/all watch exprs - B<|>[B<|>]I Send output to pager B<$psh>\[B<$psh>\] I Run cmd in a subprocess - B or B<^D> Quit B Attempt a restart -I B Execute perl code, also see: B,B,B I - B|B I Evals expr in list context, dumps the result or lists methods. - B

I Print expression (uses script's current package). - B [[B]I] List subroutine names [not] matching pattern - B [I [I]] List Variables in Package. Vars can be ~pattern or !pattern. - B [I] Same as \"B I [I]\". - B [I [I]] List lexicals in higher scope . Vars same as B. -For more help, type B I, or run B<$doccmd perldebug> for all docs. -END_SUM - - # ')}}; # Fix balance of vi % matching - - # and this is really numb... - $pre580_help = " -B Stack trace. -B [I] Single step [in I]. -B [I] Next, steps over subroutine calls [in I]. -B> Repeat last B or B command. -B Return from current subroutine. -B [I|I] Continue; optionally inserts a one-time-only breakpoint - at the specified position. -B IB<+>I List I+1 lines starting at I. -B IB<->I List lines I through I. -B I List single I. -B I List first window of lines from subroutine. -B I<\$var> List first window of lines from subroutine referenced by I<\$var>. -B List next window of lines. -B<-> List previous window of lines. -B [I] List window around I. -B<.> Return to the executed line. -B I Switch to viewing I. File must be already loaded. - I may be either the full name of the file, or a regular - expression matching the full file name: - B I and B I may access the same file. - Evals (with saved bodies) are considered to be filenames: - B I<(eval 7)> and B I access the body of the 7th eval - (in the order of execution). -BIB Search forwards for I; final B is optional. -BIB Search backwards for I; final B is optional. -B List all breakpoints and actions. -B [[B]I] List subroutine names [not] matching I. -B Toggle trace mode. -B I Trace through execution of I. -B [I] [I] - Set breakpoint; I defaults to the current execution line; - I breaks if it evaluates to true, defaults to '1'. -B I [I] - Set breakpoint at first line of subroutine. -B I<\$var> Set breakpoint at first line of subroutine referenced by I<\$var>. -B B I Set breakpoint on `require'ing the given file. -B B I [I] - Set breakpoint at first line of subroutine after - it is compiled. -B B I - Stop after the subroutine is compiled. -B [I] Delete the breakpoint for I. -B Delete all breakpoints. -B [I] I - Set an action to be done before the I is executed; - I defaults to the current execution line. - Sequence is: check for breakpoint/watchpoint, print line - if necessary, do action, prompt user if necessary, - execute line. -B [I] Delete the action for I. -B Delete all actions. -B I Add a global watch-expression. -B Delete all watch-expressions. -B [I [I]] List some (default all) variables in package (default current). - Use B<~>I and BI for positive and negative regexps. -B [I] Same as \"B I [I]\". -B I Evals expression in list context, dumps the result. -B I Evals expression in list context, prints methods callable - on the first element of the result. -B I Prints methods callable via the given class. - -B<<> ? List Perl commands to run before each prompt. -B<<> I Define Perl command to run before each prompt. -B<<<> I Add to the list of Perl commands to run before each prompt. -B<>> ? List Perl commands to run after each prompt. -B<>> I Define Perl command to run after each prompt. -B<>>B<>> I Add to the list of Perl commands to run after each prompt. -B<{> I Define debugger command to run before each prompt. -B<{> ? List debugger commands to run before each prompt. -B<{{> I Add to the list of debugger commands to run before each prompt. -B<$prc> I Redo a previous command (default previous command). -B<$prc> I<-number> Redo number'th-to-last command. -B<$prc> I Redo last command that started with I. - See 'B I' too. -B<$psh$psh> I Run cmd in a subprocess (reads from DB::IN, writes to DB::OUT)" - . ( - $rc eq $sh - ? "" - : " -B<$psh> [I] Run I in subshell (forces \"\$SHELL -c 'cmd'\")." - ) . - " - See 'B I' too. -B I Execute I containing debugger commands (may nest). -B I<-number> Display last number commands (default all). -B

I Same as \"I\" in current package. -B<|>I Run debugger command, piping DB::OUT to current pager. -B<||>I Same as B<|>I but DB::OUT is temporarilly select()ed as well. -B<\=> [I I] Define a command alias, or list current aliases. -I Execute as a perl statement in current package. -B Show versions of loaded modules. -B Pure-man-restart of debugger, some of debugger state - and command-line options may be lost. - Currently the following settings are preserved: - history, breakpoints and actions, debugger Bptions - and the following command-line options: I<-w>, I<-I>, I<-e>. - -B [I] ... Set boolean option to true -B [IB] Query options -B [IB<=>I] [I=B<\">IB<\">] ... - Set options. Use quotes in spaces in value. - I, I chars used to recall command or spawn shell; - I program for output of \"|cmd\"; - I run Tk while prompting (with ReadLine); - I I I level of verbosity; - I Allows stepping off the end of the script. - I Debugger should stop as early as possible. - I Remote hostname:port for remote debugging - The following options affect what happens with B, B, and B commands: - I, I print only first N elements ('' for all); - I, I change style of array and hash dump; - I whether to print contents of globs; - I dump arrays holding debugged files; - I dump symbol tables of packages; - I dump contents of \"reused\" addresses; - I, I, I change style of string dump; - I Do not print the overload-stringified value; - Other options include: - I affects printing of return value after B command, - I affects printing messages on subroutine entry/exit. - I affects printing messages on possible breaking points. - I gives max length of evals/args listed in stack trace. - I affects screen appearance of the command line. - I bits control attempts to create a new TTY on events: - 1: on fork() 2: debugger is started inside debugger - 4: on startup - During startup options are initialized from \$ENV{PERLDB_OPTS}. - You can put additional initialization options I, I, - I, I, and I there (or use - `B' after you set them). - -B or B<^D> Quit. Set B<\$DB::finished = 0> to debug global destruction. -B [I] Get help [on a specific debugger command], enter B<|h> to page. -B Summary of debugger commands. -B<$doccmd> I Runs the external doc viewer B<$doccmd> command on the - named Perl I, or on B<$doccmd> itself if omitted. - Set B<\$DB::doccmd> to change viewer. - -Type `|h' for a paged display if this was too hard to read. - -"; # Fix balance of vi % matching: }}}} - - # note: tabs in the following section are not-so-helpful - $pre580_summary = <<"END_SUM"; -I I - B [I|I] List source code B Stack trace - B<-> or B<.> List previous/current line B [I] Single step [in expr] - B [I] List around line B [I] Next, steps over subs - B I View source in file /B> Repeat last B or B - BIB BIB Search forw/backw B Return from subroutine - B Show versions of modules B [I|I] Continue until position -I B List break/watch/actions - B [...] Set debugger options B [I] Toggle trace [trace expr] - B<<>[B<<>]|B<{>[B<{>]|B<>>[B<>>] [I] Do pre/post-prompt B [I|I|I] [I] Set breakpoint - B<$prc> [I|I] Redo a previous command B [I] or B Delete a/all breakpoints - B [I<-num>] Display last num commands B [I] I Do cmd before line - B<=> [I I] Define/list an alias B I Add a watch expression - B [I] Get help on command B or B Delete all actions/watch - B<|>[B<|>]I Send output to pager B<$psh>\[B<$psh>\] I Run cmd in a subprocess - B or B<^D> Quit B Attempt a restart -I B Execute perl code, also see: B,B,B I - B|B I Evals expr in list context, dumps the result or lists methods. - B

I Print expression (uses script's current package). - B [[B]I] List subroutine names [not] matching pattern - B [I [I]] List Variables in Package. Vars can be ~pattern or !pattern. - B [I] Same as \"B I [I]\". - B [I [I]] List lexicals in higher scope . Vars same as B. -For more help, type B I, or run B<$doccmd perldebug> for all docs. -END_SUM - - # ')}}; # Fix balance of vi % matching - -} ## end sub sethelp - -=head2 C - -Most of what C does is just text formatting. It finds the -C and C ornaments, cleans them off, and substitutes the proper -terminal control characters to simulate them (courtesy of -). - -=cut - -sub print_help { - local $_ = shift; - - # Restore proper alignment destroyed by eeevil I<> and B<> - # ornaments: A pox on both their houses! - # - # A help command will have everything up to and including - # 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 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 : "") - . $command - . ((" " x (16 + ($leadwhite ? 4 : 0) - length($clean))) || " ") - . $text; - - }mgex; - - s{ # handle bold ornaments - B < ( [^>] + | > ) > - } { - $Term::ReadLine::TermCap::rl_term_set[2] - . $1 - . $Term::ReadLine::TermCap::rl_term_set[3] - }gex; - - s{ # handle italic ornaments - I < ( [^>] + | > ) > - } { - $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 - -This routine does a lot of gyrations to be sure that the pager is C. -It checks for C masquerading as C 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/) { - # 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! - # '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 - -C is a just-drop-dead C 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) { - # 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"; - } - - # Drop dead. - kill 'ABRT', $$; -} ## end sub diesignal - -=head2 C - -The debugger's own default C<$SIG{__WARN__}> handler. We load C to -be able to get a stack trace, and output the warning message vi C. - -=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 - -The debugger's own C<$SIG{__DIE__}> handler. Handles providing a stack trace -by loading C and calling C to get it. We turn off -single stepping and tracing during the call to C to avoid -debugging it - we just want to use it. - -If C 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 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 - } - - # 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 - -Set the C<$DB::warnLevel> variable that stores the value of the -C option. Calling C with a positive value -results in the debugger taking over all warning handlers. Setting -C 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; - } - } ## end if (@_) - $warnLevel; -} ## end sub warnLevel - -=head2 C - -Similar to C. Non-zero values for C result in the -C function overriding any other C handler. Setting it to -zero lets you use your own C handler. - -=cut - -sub 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 - -Number three in a series: set C to zero to keep your own -signal handler for C and/or C. Otherwise, the debugger -takes over and handles them with C. - -=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; - } - } ## end if (@_) - $signalLevel; -} ## end sub signalLevel - -=head1 SUBROUTINE DECODING SUPPORT - -These subroutines are used during the C and C commands to try to -produce as much information as possible about a code reference. They use -L 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 - -Wrapper for X; 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; -} - -=head2 C I - -Calls L to try to find the glob the ref lives in; returns -C if L can't be loaded, or if C can't -find a glob for this ref. - -Returns "I::I" 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}; -} ## end sub CvGV_name_or_bust - -=head2 C - -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 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 \&$_; - } - $sub{$s} if $s; - } ## end do -} ## end sub find_sub - -=head2 C - -A subroutine that uses the utility function X to find all the -methods in the class corresponding to the current reference and in -C. - -=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 - -C 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); - } -} ## end sub methods_via - -=head2 C - figure out which command to use to show documentation - -Just checks the contents of C<$^O> and sets the C<$doccmd> global accordingly. - -=cut - -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 - 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 to avoid mucking up the -program's STDIN and STDOUT. - -=cut - -sub runman { - my $page = shift; - unless ($page) { - &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; - } - - $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/ } - 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 - ) - ) - { - 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}; - } -} ## 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 requires have to be defined before -any subroutines can be called. These are defined in the second C 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 command's window. - -=item * The before-this-line context to be printed in a C (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. - -=back - -=cut - -# The following BEGIN is very handy if debugger goes havoc, debugging debugger? - -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; - -} ## end BEGIN - -BEGIN { $^W = $ini_warn; } # Switch warnings back - -=head1 READLINE SUPPORT - COMPLETION FUNCTION - -=head2 db_complete - -C support - adds command completion to basic C. - -Returns a list of possible completions to C when invoked. C -will print the longest common substring following the text already entered. - -If there is only a single possible completion, C will use it in full. - -This code uses C and C 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 - # $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 - -=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 out the ones that match the text we have so far - -=item * Return this as the list of possible completions - -=back - -=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 - -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 (list variable) and C (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*$/; - -=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 - switch files - -Here, we want to get a fully-qualified filename for the C command. -Possibilities are: - -=over 4 - -=item 1. The original source file itself - -=item 2. A file from C<@INC> - -=item 3. An C (the debugger gets a C<(eval N)> fake file for each C). - -=back - -=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/fullpath/to/file> -(Cs are C<_E(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) 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 out all the possible hashes/arrays/scalars, and then C the possible matches out of those. C 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; +sub LineInfo { + return $lineinfo unless @_; + $lineinfo = shift; + my $stream = ($lineinfo =~ /^(\+?\>|\|)/) ? $lineinfo : ">$lineinfo"; + $slave_editor = ($stream =~ /^\|/); + open(LINEINFO, "$stream") || &warn("Cannot open `$stream' for write"); + $LINEINFO = \*LINEINFO; + my $save = select($LINEINFO); + $| = 1; + select($save); + $lineinfo; +} - } ## end if ($text =~ /^[\$@%](.*)::(.*)/) +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); +} -=pod +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. -=back + $help = " +Help is currently only available for the new 580 CommandSet, +if you really want old behaviour, presumably you know what +you're doing ?-) -=head3 Symbol completion: current package or package C

. +B Stack trace. +B [I] Single step [in I]. +B [I] Next, steps over subroutine calls [in I]. +> Repeat last B or B command. +B Return from current subroutine. +B [I|I] Continue; optionally inserts a one-time-only breakpoint + at the specified position. +B IB<+>I List I+1 lines starting at I. +B IB<->I List lines I through I. +B I List single I. +B I List first window of lines from subroutine. +B I<\$var> List first window of lines from subroutine referenced by I<\$var>. +B List next window of lines. +B<-> List previous window of lines. +B [I] View window around I. +B<.> Return to the executed line. +B I Switch to viewing I. File must be already loaded. + I may be either the full name of the file, or a regular + expression matching the full file name: + B I and B I may access the same file. + Evals (with saved bodies) are considered to be filenames: + B I<(eval 7)> and B I access the body of the 7th eval + (in the order of execution). +BIB Search forwards for I; final B is optional. +BIB Search backwards for I; final B is optional. +B [I] List actions and or breakpoints and or watch-expressions. +B [[B]I] List subroutine names [not] matching I. +B Toggle trace mode. +B I Trace through execution of I. +B Sets breakpoint on current line) +B [I] [I] + Set breakpoint; I defaults to the current execution line; + I breaks if it evaluates to true, defaults to '1'. +B I [I] + Set breakpoint at first line of subroutine. +B I<\$var> Set breakpoint at first line of subroutine referenced by I<\$var>. +B B I Set breakpoint on 'require'ing the given file. +B B I [I] + Set breakpoint at first line of subroutine after + it is compiled. +B B I + Stop after the subroutine is compiled. +B [I] Delete the breakpoint for I. +B I<*> Delete all breakpoints. +B [I] I + Set an action to be done before the I is executed; + I defaults to the current execution line. + Sequence is: check for breakpoint/watchpoint, print line + if necessary, do action, prompt user if necessary, + execute line. +B Does nothing +B [I] Delete the action for I. +B I<*> Delete all actions. +B I Add a global watch-expression. +B Does nothing +B I Delete a global watch-expression. +B I<*> Delete all watch-expressions. +B [I [I]] List some (default all) variables in package (default current). + Use B<~>I and BI for positive and negative regexps. +B [I] Same as \"B I [I]\". +B [I [I]] List lexicals in higher scope . Vars same as B. +B I Evals expression in list context, dumps the result. +B I Evals expression in list context, prints methods callable + on the first element of the result. +B I Prints methods callable via the given class. +B Show versions of loaded modules. +B [I [I]] List lexical variables I levels up from current sub -=over 4 +B<<> ? List Perl commands to run before each prompt. +B<<> I Define Perl command to run before each prompt. +B<<<> I 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<>> ? List Perl commands to run after each prompt. +B<>> I Define Perl command to run after each prompt. +B<>>B<>> I 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<{> I Define debugger command to run before each prompt. +B<{> ? List debugger commands to run before each prompt. +B<{{> I 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 Redo a previous command (default previous command). +B<$prc> I<-number> Redo number'th-to-last command. +B<$prc> I Redo last command that started with I. + See 'B I' too. +B<$psh$psh> I Run cmd in a subprocess (reads from DB::IN, writes to DB::OUT)" + . ( $rc eq $sh ? "" : " +B<$psh> [I] Run I in subshell (forces \"\$SHELL -c 'cmd'\")." ) . " + See 'B I' too. +B I Execute I containing debugger commands (may nest). +B I<-number> Display last number commands (default all). +B

I Same as \"I\" in current package. +B<|>I Run debugger command, piping DB::OUT to current pager. +B<||>I Same as B<|>I but DB::OUT is temporarilly select()ed as well. +B<\=> [I I] Define a command alias, or list current aliases. +I Execute as a perl statement in current package. +B Pure-man-restart of debugger, some of debugger state + and command-line options may be lost. + Currently the following settings are preserved: + history, breakpoints and actions, debugger Bptions + and the following command-line options: I<-w>, I<-I>, I<-e>. -=cut +B [I] ... Set boolean option to true +B [IB] Query options +B [IB<=>I] [I=B<\">IB<\">] ... + Set options. Use quotes in spaces in value. + I, I chars used to recall command or spawn shell; + I program for output of \"|cmd\"; + I run Tk while prompting (with ReadLine); + I I I level of verbosity; + I Allows stepping off the end of the script. + I Debugger should stop as early as possible. + I Remote hostname:port for remote debugging + The following options affect what happens with B, B, and B commands: + I, I print only first N elements ('' for all); + I, I change style of array and hash dump; + I whether to print contents of globs; + I dump arrays holding debugged files; + I dump symbol tables of packages; + I dump contents of \"reused\" addresses; + I, I, I change style of string dump; + I Do not print the overload-stringified value; + Other options include: + I affects printing of return value after B command, + I affects printing messages on subroutine entry/exit. + I affects printing messages on possible breaking points. + I gives max length of evals/args listed in stack trace. + I affects screen appearance of the command line. + I bits control attempts to create a new TTY on events: + 1: on fork() 2: debugger is started inside debugger + 4: on startup + During startup options are initialized from \$ENV{PERLDB_OPTS}. + You can put additional initialization options I, I, + I, I, and I there (or use + `B' after you set them). +B or B<^D> Quit. Set B<\$DB::finished = 0> to debug global destruction. +B Summary of debugger commands. +B [I] Get help [on a specific debugger command], enter B<|h> to page. +B Long help for debugger commands +B<$doccmd> I Runs the external doc viewer B<$doccmd> command on the + named Perl I, or on B<$doccmd> itself if omitted. + Set B<\$DB::doccmd> to change viewer. - if ($text =~ /^[\$@%]/) { # symbols (in $package + packages in main) +Type `|h h' for a paged display if this was too hard to read. -=pod +"; # Fix balance of vi % matching: }}}} -=item * If it's C

, delete main to just get C<::> leading. + # note: tabs in the following section are not-so-helpful + $summary = <<"END_SUM"; +I I + B [I|I] List source code B Stack trace + B<-> or B<.> List previous/current line B [I] Single step [in expr] + B [I] View around line B [I] Next, steps over subs + B I View source in file /B> Repeat last B or B + BIB BIB Search forw/backw B Return from subroutine + B Show module versions B [I|I] Continue until position +I B List break/watch/actions + B [...] Set debugger options B [I] Toggle trace [trace expr] + B<<>[B<<>]|B<{>[B<{>]|B<>>[B<>>] [I] Do pre/post-prompt B [I|I|I] [I] Set breakpoint + B<$prc> [I|I] Redo a previous command B I Delete a/all breakpoints + B [I<-num>] Display last num commands B [I] I Do cmd before line + B<=> [I I] Define/list an alias B I Delete a/all actions + B [I] Get help on command B I Add a watch expression + B Complete help page B I Delete a/all watch exprs + B<|>[B<|>]I Send output to pager B<$psh>\[B<$psh>\] I Run cmd in a subprocess + B or B<^D> Quit B Attempt a restart +I B Execute perl code, also see: B,B,B I + B|B I Evals expr in list context, dumps the result or lists methods. + B

I Print expression (uses script's current package). + B [[B]I] List subroutine names [not] matching pattern + B [I [I]] List Variables in Package. Vars can be ~pattern or !pattern. + B [I] Same as \"B I [I]\". + B [I [I]] List lexicals in higher scope . Vars same as B. +For more help, type B I, or run B<$doccmd perldebug> for all docs. +END_SUM + # ')}}; # Fix balance of vi % matching -=cut + # and this is really numb... + $pre580_help = " +B Stack trace. +B [I] Single step [in I]. +B [I] Next, steps over subroutine calls [in I]. +> Repeat last B or B command. +B Return from current subroutine. +B [I|I] Continue; optionally inserts a one-time-only breakpoint + at the specified position. +B IB<+>I List I+1 lines starting at I. +B IB<->I List lines I through I. +B I List single I. +B I List first window of lines from subroutine. +B I<\$var> List first window of lines from subroutine referenced by I<\$var>. +B List next window of lines. +B<-> List previous window of lines. +B [I] List window around I. +B<.> Return to the executed line. +B I Switch to viewing I. File must be already loaded. + I may be either the full name of the file, or a regular + expression matching the full file name: + B I and B I may access the same file. + Evals (with saved bodies) are considered to be filenames: + B I<(eval 7)> and B I access the body of the 7th eval + (in the order of execution). +BIB Search forwards for I; final B is optional. +BIB Search backwards for I; final B is optional. +B List all breakpoints and actions. +B [[B]I] List subroutine names [not] matching I. +B Toggle trace mode. +B I Trace through execution of I. +B [I] [I] + Set breakpoint; I defaults to the current execution line; + I breaks if it evaluates to true, defaults to '1'. +B I [I] + Set breakpoint at first line of subroutine. +B I<\$var> Set breakpoint at first line of subroutine referenced by I<\$var>. +B B I Set breakpoint on `require'ing the given file. +B B I [I] + Set breakpoint at first line of subroutine after + it is compiled. +B B I + Stop after the subroutine is compiled. +B [I] Delete the breakpoint for I. +B Delete all breakpoints. +B [I] I + Set an action to be done before the I is executed; + I defaults to the current execution line. + Sequence is: check for breakpoint/watchpoint, print line + if necessary, do action, prompt user if necessary, + execute line. +B [I] Delete the action for I. +B Delete all actions. +B I Add a global watch-expression. +B Delete all watch-expressions. +B [I [I]] List some (default all) variables in package (default current). + Use B<~>I and BI for positive and negative regexps. +B [I] Same as \"B I [I]\". +B I Evals expression in list context, dumps the result. +B I Evals expression in list context, prints methods callable + on the first element of the result. +B I Prints methods callable via the given class. - $pack = ($package eq 'main' ? '' : $package) . '::'; +B<<> ? List Perl commands to run before each prompt. +B<<> I Define Perl command to run before each prompt. +B<<<> I Add to the list of Perl commands to run before each prompt. +B<>> ? List Perl commands to run after each prompt. +B<>> I Define Perl command to run after each prompt. +B<>>B<>> I Add to the list of Perl commands to run after each prompt. +B<{> I Define debugger command to run before each prompt. +B<{> ? List debugger commands to run before each prompt. +B<{{> I Add to the list of debugger commands to run before each prompt. +B<$prc> I Redo a previous command (default previous command). +B<$prc> I<-number> Redo number'th-to-last command. +B<$prc> I Redo last command that started with I. + See 'B I' too. +B<$psh$psh> I Run cmd in a subprocess (reads from DB::IN, writes to DB::OUT)" + . ( $rc eq $sh ? "" : " +B<$psh> [I] Run I in subshell (forces \"\$SHELL -c 'cmd'\")." ) . " + See 'B I' too. +B I Execute I containing debugger commands (may nest). +B I<-number> Display last number commands (default all). +B

I Same as \"I\" in current package. +B<|>I Run debugger command, piping DB::OUT to current pager. +B<||>I Same as B<|>I but DB::OUT is temporarilly select()ed as well. +B<\=> [I I] Define a command alias, or list current aliases. +I Execute as a perl statement in current package. +B Show versions of loaded modules. +B Pure-man-restart of debugger, some of debugger state + and command-line options may be lost. + Currently the following settings are preserved: + history, breakpoints and actions, debugger Bptions + and the following command-line options: I<-w>, I<-I>, I<-e>. -=pod +B [I] ... Set boolean option to true +B [IB] Query options +B [IB<=>I] [I=B<\">IB<\">] ... + Set options. Use quotes in spaces in value. + I, I chars used to recall command or spawn shell; + I program for output of \"|cmd\"; + I run Tk while prompting (with ReadLine); + I I I level of verbosity; + I Allows stepping off the end of the script. + I Debugger should stop as early as possible. + I Remote hostname:port for remote debugging + The following options affect what happens with B, B, and B commands: + I, I print only first N elements ('' for all); + I, I change style of array and hash dump; + I whether to print contents of globs; + I dump arrays holding debugged files; + I dump symbol tables of packages; + I dump contents of \"reused\" addresses; + I, I, I change style of string dump; + I Do not print the overload-stringified value; + Other options include: + I affects printing of return value after B command, + I affects printing messages on subroutine entry/exit. + I affects printing messages on possible breaking points. + I gives max length of evals/args listed in stack trace. + I affects screen appearance of the command line. + I bits control attempts to create a new TTY on events: + 1: on fork() 2: debugger is started inside debugger + 4: on startup + During startup options are initialized from \$ENV{PERLDB_OPTS}. + You can put additional initialization options I, I, + I, I, and I there (or use + `B' after you set them). -=item * We set the prefix to the item's sigil, and trim off the sigil to get the text to be completed. +B or B<^D> Quit. Set B<\$DB::finished = 0> to debug global destruction. +B [I] Get help [on a specific debugger command], enter B<|h> to page. +B Summary of debugger commands. +B<$doccmd> I Runs the external doc viewer B<$doccmd> command on the + named Perl I, or on B<$doccmd> itself if omitted. + Set B<\$DB::doccmd> to change viewer. -=cut +Type `|h' for a paged display if this was too hard to read. - $prefix = substr $text, 0, 1; - $text = substr $text, 1; +"; # Fix balance of vi % matching: }}}} -=pod + # note: tabs in the following section are not-so-helpful + $pre580_summary = <<"END_SUM"; +I I + B [I|I] List source code B Stack trace + B<-> or B<.> List previous/current line B [I] Single step [in expr] + B [I] List around line B [I] Next, steps over subs + B I View source in file /B> Repeat last B or B + BIB BIB Search forw/backw B Return from subroutine + B Show versions of modules B [I|I] Continue until position +I B List break/watch/actions + B [...] Set debugger options B [I] Toggle trace [trace expr] + B<<>[B<<>]|B<{>[B<{>]|B<>>[B<>>] [I] Do pre/post-prompt B [I|I|I] [I] Set breakpoint + B<$prc> [I|I] Redo a previous command B [I] or B Delete a/all breakpoints + B [I<-num>] Display last num commands B [I] I Do cmd before line + B<=> [I I] Define/list an alias B I Add a watch expression + B [I] Get help on command B or B Delete all actions/watch + B<|>[B<|>]I Send output to pager B<$psh>\[B<$psh>\] I Run cmd in a subprocess + B or B<^D> Quit B Attempt a restart +I B Execute perl code, also see: B,B,B I + B|B I Evals expr in list context, dumps the result or lists methods. + B

I Print expression (uses script's current package). + B [[B]I] List subroutine names [not] matching pattern + B [I [I]] List Variables in Package. Vars can be ~pattern or !pattern. + B [I] Same as \"B I [I]\". + B [I [I]] List lexicals in higher scope . Vars same as B. +For more help, type B I, or run B<$doccmd perldebug> for all docs. +END_SUM + # ')}}; # Fix balance of vi % matching -=item * If the package is C<::> (C

), 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 out the matches to the text entered so far, then C the prefix back onto the symbols. +} -=cut +sub print_help { + local $_ = shift; - my @out = map "$prefix$_", grep /^\Q$text/, - (grep /^_?[a-zA-Z]/, keys %$pack), - ($pack eq '::' ? () : (grep /::$/, keys %::)); + # Restore proper alignment destroyed by eeevil I<> and B<> + # ornaments: A pox on both their houses! + # + # A help command will have everything up to and including + # 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 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 : "") + . $command + . ((" " x (16 + ($leadwhite ? 4 : 0) - length($clean))) || " ") + . $text; -=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. + }mgex; -=back + s{ # handle bold ornaments + B < ( [^>] + | > ) > + } { + $Term::ReadLine::TermCap::rl_term_set[2] + . $1 + . $Term::ReadLine::TermCap::rl_term_set[3] + }gex; -=cut + s{ # handle italic ornaments + I < ( [^>] + | > ) > + } { + $Term::ReadLine::TermCap::rl_term_set[0] + . $1 + . $Term::ReadLine::TermCap::rl_term_set[1] + }gex; - if (@out == 1 and $out[0] =~ /::$/ and $out[0] ne $itext) { - return db_complete($out[0], $line, $start); - } + local $\ = ''; + print $OUT $_; +} - # Return the list of possibles. - return sort @out; - } ## end if ($text =~ /^[\$@%]/) +sub fix_less { + return if defined $ENV{LESS} && $ENV{LESS} =~ /r/; + 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]; + } + # changes environment! + $ENV{LESS} .= 'r' if $is_less; +} -=head3 Options +sub diesignal { + local $frame = 0; + local $doret = -2; + $SIG{'ABRT'} = 'DEFAULT'; + kill 'ABRT', $$ if $panic++; + if (defined &Carp::longmess) { + local $SIG{__WARN__} = ''; + local $Carp::CarpLevel = 2; # mydie + confess + &warn(Carp::longmess("Signal @_")); + } + else { + local $\ = ''; + print $DB::OUT "Got signal @_\n"; + } + kill 'ABRT', $$; +} -We use C 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. +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); +} -=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; +} - # 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); +sub warnLevel { + if (@_) { + $prevwarn = $SIG{__WARN__} unless $warnLevel; + $warnLevel = shift; + if ($warnLevel) { + $SIG{__WARN__} = \&DB::dbwarn; + } elsif ($prevwarn) { + $SIG{__WARN__} = $prevwarn; + } + } + $warnLevel; +} - # 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. - } +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; +} - # We have a value. Create a proper option-setting command. - elsif ($val =~ /\s/) { - # XXX This may be an extraneous variable. - my $found; +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; +} - # 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/) +sub CvGV_name { + my $in = shift; + my $name = CvGV_name_or_bust($in); + defined $name ? $name : $in; +} - # Don't need any quotes. - else { - $out = "=$val "; - } +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}; +} - # 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 : '? '); +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 \&$_; + } + $sub{$s} if $s; + } +} - # Return list of possibilities. - return sort @out; - } ## end if ((substr $line, 0, ... +sub methods { + my $class = shift; + $class = ref $class if ref $class; + local %seen; + local %packs; + methods_via($class, '', 1); + methods_via('UNIVERSAL', 'UNIVERSAL', 0); +} -=head3 Filename completion +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); + } +} -For entering filenames. We simply call C's C -method with the completion text to get the possible completions. +sub setman { + $doccmd = $^O !~ /^(?:MSWin32|VMS|os2|dos|amigaos|riscos|MacOS|NetWare)\z/s + ? "man" # O Happy Day! + : "perldoc"; # Alas, poor unfortunates +} -=cut +sub runman { + my $page = shift; + unless ($page) { + &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; + } - return $term->filename_list($text); # filenames + $page = 'perl' if lc($page) eq 'help'; -} ## end sub db_complete + require Config; + my $man1dir = $Config::Config{'man1dir'}; + my $man3dir = $Config::Config{'man3dir'}; + 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) ) + { + 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); + } + } + } + if (defined $oldpath) { + $ENV{MANPATH} = $manpath; + } else { + delete $ENV{MANPATH}; + } +} -=head1 MISCELLANEOUS SUPPORT FUNCTIONS +# The following BEGIN is very handy if debugger goes havoc, debugging debugger? -Functions that possibly ought to be somewhere else. +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; +} -=head2 end_report +BEGIN {$^W = $ini_warn;} # Switch warnings back -Say we're done. +#use Carp; # This did break, left for debugging -=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 + 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 +} 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 (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 BLOCK - -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. +} -First we set the C<$finished> variable, so that some commands that -shouldn't be run after the end of program quit working. -We then figure out whether we're truly done (as in the user entered a C -command, or we finished execution while running nonstop). If we aren't, -we set C<$single> to 1 (causing the debugger to get control again). +# 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 + ); -We then call C, which returns the C -message and returns control to the debugger. Repeat. + %DollarCaretP_flags_r=reverse %DollarCaretP_flags; +} -When the user finally enters a C command, C<$fall_off_end> is set to -1 and the C block simply exits with C<$single> set to 0 (don't -break, run to completion.). +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; +} -=cut +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; +} END { - $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 - -=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 + $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; +} -Does nothing. Used to 'turn off' commands. -=cut +# ===================================== pre580 ================================ +# this is very sad below here... +# sub cmd_pre580_null { - - # do nothing... + # do nothing... } -=head2 Old C 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; - - # 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 command - -Add breakpoints. - -=cut + 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 ''; + } + } +} sub cmd_pre580_b { - 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 [] - # 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 [] - elsif ($cmd =~ /^([':A-Za-z_][':\w]*(?:\[.*\])?)\s*(.*)/) { - my $subname = $1; - my $cond = length $2 ? $2 : '1'; - &cmd_b_sub($subname, $cond); - } - - # b []. - 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 command. - -Delete all breakpoints unconditionally. - -=cut + 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); + } +} sub cmd_pre580_D { - 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 command - -Print help. Defaults to printing the long-form help; the 5.8 version -prints the summary by default. - -=cut + 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; + } +} sub cmd_pre580_h { - 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 - if ($pre580_help =~ /^ - is not a debugger command.\n"); - } - } ## end elsif ($cmd =~ /^h\s+(\S.*)$/) -} ## end sub cmd_pre580_h - -=head2 Old C command - -CexprE> adds a watch expression, C deletes them all. - -=cut + 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 + if ($pre580_help =~ /^ is not a debugger command.\n"); + } + } +} sub cmd_pre580_W { - 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 and -C unify all this into one set of code to handle the -appropriate actions. - -=head2 C - -A small wrapper around C; 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 + 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; + } +} sub cmd_pre590_prepost { - my $cmd = shift; - my $line = shift || '*'; - my $dbline = shift; - - return &cmd_prepost( $cmd, $line, $dbline ); -} ## end sub cmd_pre590_prepost + my $cmd = shift; + my $line = shift || '*'; # delete + my $dbline = shift; -=head2 C - -Actually does all the handling foe C>, C>, 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 =~ /^\ - 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"; - } + return &cmd_prepost($cmd, $line, $dbline); +} - # 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 - -Contains the C routine that the debugger uses to issue the -C message after the program completes. See -the C block documentation for more details. - -=cut +sub cmd_prepost { # cannot do &cmd_<(), <, <<, >>, {, {{, etc. + my $cmd = shift; + my $line = shift || '?'; + + my $which = ''; + my $aref = []; + if ($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"; + } + } + } +} 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; -