=head1 NAME
-C<perl5db.pl> - the perl debugger
+perl5db.pl - the perl debugger
=head1 SYNOPSIS
documented, so it's generally been a decision that hasn't made a lot of
difference to most users. Where appropriate, comments have been added to
make variables more accessible and usable, with the understanding that these
-
i<are> debugger internals, and are therefore subject to change. Future
+
I<are> debugger internals, and are therefore subject to change. Future
development should probably attempt to replace the globals with a well-defined
API, but for now, the variables are what we've got.
=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
+the second pair applies when it is. 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
+such as C<$single>, C<$trace>, and C<$frame>, have I<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.
=over 4
+=item *
-=item * First, doing an arithmetical or bitwise operation on a scalar is
+First, doing an arithmetical or bitwise operation on a scalar is
just about the fastest thing you can do in Perl: C<use constant> actually
-creates a subroutine call, and array hand hash lookups are much slower. Is
+creates a subroutine call, and array and hash lookups are much slower. Is
this over-optimization at the expense of readability? Possibly, but the
debugger accesses these variables a I<lot>. Any rewrite of the code will
probably have to benchmark alternate implementations and see which is the
best balance of readability and speed, and then document how it actually
works.
-=item * Second, it's very easy to serialize a scalar number. This is done in
+=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
+=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).
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 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>. Additionally,
+breakable lines will be dualvars with the numeric component being the
+memory address of a COP node. Non-breakable lines are dualvar to 0.
The hash C<%{'_<'.$filename}> (aliased locally to C<%dbline> via glob
assignment) contains breakpoints and actions. The keys are line numbers;
you can set individual values, but not the whole hash. The Perl interpreter
uses this hash to determine where breakpoints have been set. Any true value is
-considered to be a breakpoint; C<perl5db.pl> uses "$break_condition\0$action".
+considered to be a breakpoint; C<perl5db.pl> uses C<$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?
+The scalar C<${"_<$filename"}> simply contains the string C<_<$filename>.
+This is also the case for evaluated strings that contain subroutines, or
+which are currently being executed. The $filename for C<eval>ed strings looks
+like C<(eval 34)> or C<(re_eval 19)>.
=head1 DEBUGGER STARTUP
initialized itself.
Next, it checks the C<PERLDB_OPTS> environment variable and treats its
-contents as the argument of a debugger <C<o> command.
+contents as the argument of a C<o> command in the debugger.
=head2 STARTUP-ONLY OPTIONS
=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
+uses the value of noTTY or F<$HOME/.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
+if false, a dummy ReadLine is used, so you can debug
ReadLine applications.
=item * NonStop
host:port to connect to on remote host for remote debugging.
+=item * HistFile
+
+file to store session history to. There is no default and so no
+history file is written unless this variable is explicitly set.
+
+=item * HistSize
+
+number of commands to store to the file specified in C<HistFile>.
+Default is 100.
+
=back
=head3 SAMPLE RCFILE
The script will run without human intervention, putting trace
information into C<db.out>. (If you interrupt it, you had better
-reset C<LineInfo> to something "interactive"!)
+reset C<LineInfo> to something I<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
+a C<&DB::DB();> in front of each place that can have a
breakpoint. At each subroutine call, it calls C<&DB::sub> with
C<$DB::sub> set to the called subroutine. It also inserts a C<BEGIN
{require 'perl5db.pl'}> before the first line.
=item * 0 - No enter/exit messages
-=item * 1 - Print "entering" messages on subroutine entry
+=item * 1 - Print I<entering> messages on subroutine entry
=item * 2 - Adds exit messages on subroutine exit. If no other flag is on, acts like 1+2.
-=item * 4 - Extended messages: C<in|out> I<context>=I<fully-qualified sub name> from I<file>:I<line>>. If no other flag is on, acts like 1+4.
+=item * 4 - Extended messages: C<< <in|out> I<context>=I<fully-qualified sub name> from I<file>:I<line> >>. If no other flag is on, acts like 1+4.
=item * 8 - Adds parameter information to messages, and overloaded stringify and tied FETCH is enabled on the printed arguments. Ignored if C<4> is not on.
=back
-To get everything, use C<$frame=30> (or C<o f-30> as a debugger command).
+To get everything, use C<$frame=30> (or C<o f=30> as a debugger command).
The debugger internally juggles the value of C<$frame> during execution to
protect external modules that the debugger uses from getting traced.
=head4 C<$onetimeDumpDepth>
-Controls how far down C<dumpvar.pl> will go before printing '...' while
+Controls how far down C<dumpvar.pl> will go before printing C<...> while
dumping a structure. Numeric. If C<undef>, print all levels.
=head4 C<$signal>
=item * 0 - run continuously.
-=item * 1 - single-step, go into subs. The 's' command.
+=item * 1 - single-step, go into subs. The C<s> command.
-=item * 2 - single-step, don't go into subs. The 'n' command.
+=item * 2 - single-step, don't go into subs. The C<n> command.
-=item * 4 - print current sub depth (turned on to force this when "too much
-recursion" occurs.
+=item * 4 - print current sub depth (turned on to force this when C<too much
+recursion> occurs.
=back
=head4 C<%dbline>
-Keys are line numbers, values are "condition\0action". If used in numeric
+Keys are line numbers, values are C<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.
=over 4
-=item * 'compile' - break when this sub is compiled
+=item * C<compile> - break when this sub is compiled
-=item * 'break +0 if <condition>' - break (conditionally) at the start of this routine. The condition will be '1' if no condition was specified.
+=item * C<< break +0 if <condition> >> - break (conditionally) at the start of this routine. The condition will be '1' if no condition was specified.
=back
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").
+definitions (C<condition\0action>).
=head1 DEBUGGER INITIALIZATION
package DB;
-use IO::Handle;
+BEGIN {eval 'use IO::Handle'}; # Needed for flush only? breaks under miniperl
# Debugger for Perl 5.00x; perl5db.pl patch level:
-$VERSION = 1.27;
+$VERSION = '1.33';
$header = "perl5db.pl version $VERSION";
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<C<$trace>>, X<C<$single>>, and X<C<$^D>>;
-add the X<C<$usercontext>> (that's the preserved values of C<$@>, C<$!>,
-C<$^E>, C<$,>, C<$/>, C<$\>, and C<$^W>, grabbed when C<DB::DB> got control,
-and the user's current package) and a add a newline before we do the C<eval()>.
-This causes the proper context to be used when the eval is actually done.
-Afterward, we restore C<$trace>, C<$single>, and C<$^D>.
+Before we do the C<eval()>, we preserve the current settings of C<$trace>,
+C<$single>, C<$^D> and C<$usercontext>. The latter contains the
+preserved values of C<$@>, C<$!>, C<$^E>, C<$,>, C<$/>, C<$\>, C<$^W> and the
+user's current package, grabbed when C<DB::DB> got control. This causes the
+proper context to be used when the eval is actually done. Afterward, we
+restore C<$trace>, C<$single>, and C<$^D>.
Next we need to handle C<$@> without getting confused. We save C<$@> in a
local lexical, localize C<$saved[0]> (which is where C<save()> will put
C<$@>), and then call C<save()> to capture C<$@>, C<$!>, C<$^E>, C<$,>,
C<$/>, C<$\>, and C<$^W>) and set C<$,>, C<$/>, C<$\>, and C<$^W> to values
considered sane by the debugger. If there was an C<eval()> error, we print
-it on the debugger's output. If X<C<$onetimedump>> is defined, we call
-X<C<dumpit>> if it's set to 'dump', or X<C<methods>> if it's set to
+it on the debugger's output. If C<$onetimedump> is defined, we call
+C<dumpit> if it's set to 'dump', or C<methods> if it's set to
'methods'. Setting it to something else causes the debugger to do the eval
but not print the result - handy if you want to do something else with it
(the "watch expressions" code does this to get the value of the watch
=item C<$evalarg> - the thing to actually be eval'ed
-=item C<$trace> - Current state of execution tracing (see X<$trace>)
+=item C<$trace> - Current state of execution tracing
-=item C<$single> - Current state of single-stepping (see X<$single>)
+=item C<$single> - Current state of single-stepping
=item C<$onetimeDump> - what is to be displayed after the evaluation
# 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 $
# Enhanced by ilya@math.ohio-state.edu (Ilya Zakharevich)
# + Fix a side-effect of bug #24674 in the perl debugger ("odd taint bug")
# Changes: 1.24: Mar 03, 2004 Richard Foley <richard.foley@rfi.net>
# + Added command to save all debugger commands for sourcing later.
-# + Added command to display parent inheritence tree of given class.
+# + Added command to display parent inheritance tree of given class.
# + Fixed minor newline in history bug.
# Changes: 1.25: Apr 17, 2004 Richard Foley <richard.foley@rfi.net>
# + Fixed option bug (setting invalid options + not recognising valid short forms)
# + removed windowid restriction for forking into an xterm.
# + more whitespace again.
# + wrapped restart and enabled rerun [-n] (go back n steps) command.
-####################################################################
+# Changes: 1.28: Oct 12, 2004 Richard Foley <richard.foley@rfi.net>
+# + Added threads support (inc. e and E commands)
+# Changes: 1.29: Nov 28, 2006 Bo Lindbergh <blgl@hagernas.com>
+# + Added macosx_get_fork_TTY support
+# Changes: 1.30: Mar 06, 2007 Andreas Koenig <andk@cpan.org>
+# + Added HistFile, HistSize
+# Changes: 1.31
+# + Remove support for assertions and -A
+# + stop NEXT::AUTOLOAD from emitting warnings under the debugger. RT #25053
+# + "update for Mac OS X 10.5" [finding the tty device]
+# + "What I needed to get the forked debugger to work" [on VMS]
+# + [perl #57016] debugger: o warn=0 die=0 ignored
+# + Note, but don't use, PERLDBf_SAVESRC
+# + Fix #7013: lvalue subs not working inside debugger
+# Changes: 1.32: Jun 03, 2009 Jonathan Leto <jonathan@leto.net>
+# + Fix bug where a key _< with undefined value was put into the symbol table
+# + when the $filename variable is not set
+# Changes: 1.33:
+# + Debugger prints lines to the remote port when it forks and openes a new port (f633fd2)
+# + The debugger now continues to use RemotePort when it's been configured to use it. (11653f7)
+# + Stop using $ENV{LESS} for parameters not intended for less (d463cf2)
+# + Configure has a path to less and perl5db.pl can use it (bf320d6)
+# + Die with $@ instead of empty message (86755f4)
+# + Remove extra/useless $@ check after eval { require PadWalker } (which is still checked) (dab8d6d)
+# + Promote eval( "require ..." ) to eval { require ... } (4a49187)
+# + Promote eval { require( ... )} || die to mere require( ... ) (999f23b)
+# + Remove indirect object notation from debugger (bee4b46)
+# + Document that @{$main::{'_<'.$filename}} lines are dualvar to (COP*). (7e17a74)
+# + Remove MacOS classic support from the debugger. (2b894b7)
+########################################################################
=head1 DEBUGGER INITIALIZATION
$^W = 0;
} # Switch compilation warnings off until another BEGIN.
-# test if assertions are supported and actived:
-BEGIN {
- $ini_assertion = eval "sub asserting_test : assertion {1}; 1";
+local ($^W) = 0; # Switch run-time warnings off during init.
- # $ini_assertion = undef => assertions unsupported,
- # " = 1 => assertions supported
- # print "\$ini_assertion=$ini_assertion\n";
-}
+=head2 THREADS SUPPORT
-local ($^W) = 0; # Switch run-time warnings off during init.
+If we are running under a threaded Perl, we require threads and threads::shared
+if the environment variable C<PERL5DB_THREADED> is set, to enable proper
+threaded debugger control. C<-dt> can also be used to set this.
+
+Each new thread will be announced and the debugger prompt will always inform
+you of each new thread created. It will also indicate the thread id in which
+we are currently running within the prompt like this:
+
+ [tid] DB<$i>
+
+Where C<[tid]> is an integer thread id and C<$i> is the familiar debugger
+command prompt. The prompt will show: C<[0]> when running under threads, but
+not actually in a thread. C<[tid]> is consistent with C<gdb> usage.
+
+While running under threads, when you set or delete a breakpoint (etc.), this
+will apply to all threads, not just the currently running one. When you are
+in a currently executing thread, you will stay there until it completes. With
+the current implementation it is not currently possible to hop from one thread
+to another.
+
+The C<e> and C<E> commands are currently fairly minimal - see C<h e> and C<h E>.
+
+Note that threading support was built into the debugger as of Perl version
+C<5.8.6> and debugger version C<1.2.8>.
+
+=cut
+
+BEGIN {
+ # ensure we can share our non-threaded variables or no-op
+ if ($ENV{PERL5DB_THREADED}) {
+ require threads;
+ require threads::shared;
+ import threads::shared qw(share);
+ $DBGR;
+ share(\$DBGR);
+ lock($DBGR);
+ print "Threads support enabled\n";
+ } else {
+ *lock = sub(*) {};
+ *share = sub(*) {};
+ }
+}
# 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'.
+ # These variables control the execution of 'dumpvar.pl'.
$dumpvar::hashDepth,
$dumpvar::arrayDepth,
$dumpvar::dumpDBFiles,
)
if 0;
+# without threads, $filename is not defined until DB::DB is called
+foreach my $k (keys (%INC)) {
+ &share(\$main::{'_<'.$filename}) if defined $filename;
+};
+
# Command-line + PERLLIB:
# Save the contents of @INC before they are modified elsewhere.
@ini_INC = @INC;
=cut
@options = qw(
- CommandSet
+ CommandSet HistFile HistSize
hashDepth arrayDepth dumpDepth
DumpDBFiles DumpPackages DumpReused
compactDump veryCompact quote
signalLevel warnLevel dieLevel
inhibit_exit ImmediateStop bareStringify
CreateTTY RemotePort windowSize
- DollarCaretP OnlyAssertions WarnAssertions
+ DollarCaretP
);
-@RememberOnROptions = qw(DollarCaretP OnlyAssertions);
+@RememberOnROptions = qw(DollarCaretP);
=pod
ImmediateStop => \$ImmediateStop,
RemotePort => \$remoteport,
windowSize => \$window,
- WarnAssertions => \$warnassertions,
+ HistFile => \$histfile,
+ HistSize => \$histsize,
);
=pod
ornaments => \&ornaments,
RemotePort => \&RemotePort,
DollarCaretP => \&DollarCaretP,
- OnlyAssertions=> \&OnlyAssertions,
);
=pod
$CreateTTY = 3 unless defined $CreateTTY;
$CommandSet = '580' unless defined $CommandSet;
+share($rl);
+share($warnLevel);
+share($dieLevel);
+share($signalLevel);
+share($pre);
+share($post);
+share($pretype);
+share($rl);
+share($CreateTTY);
+share($CommandSet);
+
=pod
The default C<die>, C<warn>, and C<signal> handlers are set up.
=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
+environment first. If it's not defined there, we try to find it in
the Perl C<Config.pm>. If it's not there, we default to C<more>. We
then call the C<pager()> function to save the pager name.
=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
+recall character (C<!> unless otherwise defined) and the shell escape
+character (C<!> unless otherwise defined). Yes, these do conflict, and
neither works in the debugger at the moment.
=cut
=head2 SETTING UP THE DEBUGGER GREETING
-The debugger 'greeting' helps to inform the user how many debuggers are
+The debugger I<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
# 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;
+
+ my $env_pids = $ENV{PERLDB_PIDS};
+ $pids = "[$env_pids]";
+
+ # Unless we are on OpenVMS, all programs under the DCL shell run under
+ # the same PID.
+
+ if (($^O eq 'VMS') && ($env_pids =~ /\b$$\b/)) {
+ $term_pid = $$;
+ }
+ else {
+ $ENV{PERLDB_PIDS} .= "->$$";
+ $term_pid = -1;
+ }
+
} ## end if (defined $ENV{PERLDB_PIDS...
else {
# 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=$$}";
+ $pids = "[pid=$$]";
$term_pid = $$;
}
# 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!
+my $dev_tty = '/dev/tty';
+ $dev_tty = 'TT:' if ($^O eq 'VMS');
+if ( -e $dev_tty ) { # this is the wrong metric!
$rcfile = ".perldb";
}
else {
The last thing we do during initialization is determine which subroutine is
to be used to obtain a new terminal when a new debugger is started. Right now,
-the debugger only handles X Windows and OS/2.
+the debugger only handles TCP sockets, X Windows, OS/2, amd Mac OS X
+(darwin).
=cut
# Set up the get_fork_TTY subroutine to be aliased to the proper routine.
# Works if you're running an xterm or xterm-like window, or you're on
-# OS/2. This may need some expansion: for instance, this doesn't handle
-# OS X Terminal windows.
-
-if (
- not defined &get_fork_TTY # no routine exists,
- and defined $ENV{TERM} # and we know what kind
- # of terminal this is,
- and $ENV{TERM} eq 'xterm' # and it's an xterm,
-# and defined $ENV{WINDOWID} # and we know what window this is, <- wrong metric
- and defined $ENV{DISPLAY} # and what display it's on,
- )
+# OS/2, or on Mac OS X. This may need some expansion.
+
+if (not defined &get_fork_TTY) # only if no routine exists
{
- *get_fork_TTY = \&xterm_get_fork_TTY; # use the xterm version
+ if ( defined $remoteport ) {
+ # Expect an inetd-like server
+ *get_fork_TTY = \&socket_get_fork_TTY; # to listen to us
+ }
+ elsif (defined $ENV{TERM} # If we know what kind
+ # of terminal this is,
+ and $ENV{TERM} eq 'xterm' # and it's an xterm,
+ and defined $ENV{DISPLAY} # and what display it's on,
+ )
+ {
+ *get_fork_TTY = \&xterm_get_fork_TTY; # use the xterm version
+ }
+ elsif ( $^O eq 'os2' ) { # If this is OS/2,
+ *get_fork_TTY = \&os2_get_fork_TTY; # use the OS/2 version
+ }
+ elsif ( $^O eq 'darwin' # If this is Mac OS X
+ and defined $ENV{TERM_PROGRAM} # and we're running inside
+ and $ENV{TERM_PROGRAM}
+ eq 'Apple_Terminal' # Terminal.app
+ )
+ {
+ *get_fork_TTY = \&macosx_get_fork_TTY; # use the Mac OS X version
+ }
} ## end if (not defined &get_fork_TTY...
-elsif ( $^O eq 'os2' ) { # If this is OS/2,
- *get_fork_TTY = \&os2_get_fork_TTY; # use the OS/2 version
-}
# untaint $^O, which may have been tainted by the last statement.
# see bug [perl #24674]
%break_on_load = get_list("PERLDB_ON_LOAD");
%postponed = get_list("PERLDB_POSTPONE");
+ share(@hist);
+ share(@truehist);
+ share(%break_on_load);
+ share(%postponed);
+
# restore breakpoints/actions
my @had_breakpoints = get_list("PERLDB_VISITED");
for ( 0 .. $#had_breakpoints ) {
if ($notty) {
$runnonstop = 1;
+ share($runnonstop);
}
=pod
$console = "con";
}
-=item * MacOS - use C<Dev:Console:Perl Debug> if this is the MPW version; C<Dev:
-Console> if not. (Note that Mac OS X returns 'darwin', not 'MacOS'. Also note that the debugger doesn't do anything special for 'darwin'. Maybe it should.)
-
-=cut
-
- elsif ( $^O eq 'MacOS' ) {
- if ( $MacPerl::Version !~ /MPW/ ) {
- $console =
- "Dev:Console:Perl Debug"; # Separate window for application
- }
- else {
- $console = "Dev:Console";
- }
- } ## end elsif ($^O eq 'MacOS')
-
=item * VMS - use C<sys$command>.
=cut
# 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;
+ $IN = $OUT = connect_remoteport();
} ## end if (defined $remoteport)
=pod
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.)
+ # outs to open. (They are assumed identical if not.)
my ( $i, $o ) = split /,/, $console;
$o = $i unless defined $o;
# and a I/O description to keep track of.
$LINEINFO = $OUT unless defined $LINEINFO;
$lineinfo = $console unless defined $lineinfo;
+ # share($LINEINFO); # <- unable to share globs
+ share($lineinfo); #
=pod
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.
+them, and then 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"
+to create other commands to be executed later. This is all highly I<optimized>
but can be confusing. Check the comments for each C<$cmd ... && do {}> to
see what's happening in any given command.
sub DB {
+ # lock the debugger and get the thread id for the prompt
+ lock($DBGR);
+ my $tid;
+ if ($ENV{PERL5DB_THREADED}) {
+ $tid = eval { "[".threads->tid."]" };
+ }
+
# 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++ ) {
# the code here.
local (*dbline) = $main::{ '_<' . $filename };
- # we need to check for pseudofiles on Mac OS (these are files
- # not attached to a filename, but instead stored in Dev:Pseudo)
- if ( $^O eq 'MacOS' && $#dbline < 0 ) {
- $filename_ini = $filename = 'Dev:Pseudo';
- *dbline = $main::{ '_<' . $filename };
- }
-
# Last line in the program.
local $max = $#dbline;
=over 4
-=item * Returning a false value from the C<watchfunction()> itself.
+=item *
-=item * Altering C<$single> to a false value.
+Returning a false value from the C<watchfunction()> itself.
-=item * Altering C<$signal> to a false value.
+=item *
-=item * Turning off the '4' bit in C<$trace> (this also disables the
+Altering C<$single> to a false value.
+
+=item *
+
+Altering C<$signal> to a false value.
+
+=item *
+
+Turning off the C<4> bit in C<$trace> (this also disables the
check for C<watchfunction()>. This can be done with
$trace &= ~4;
$term || &setterm;
print_help(<<EOP);
Debugged program terminated. Use B<q> to quit or B<R> to restart,
- use B<O> I<inhibit_exit> to avoid stopping after program termination,
- B<h q>, B<h R> or B<h O> to get additional info.
+ use B<o> I<inhibit_exit> to avoid stopping after program termination,
+ B<h q>, B<h R> or B<h o> to get additional info.
EOP
# Set the DB::eval context appropriately.
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.
-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"
+C<$incr> controls by how many lines the I<current> line should move forward
+after a command is executed. If set to -1, this indicates that the I<current>
line shouldn't change.
-C<$start> is the "current" line. It is used for things like knowing where to
+C<$start> is the I<current> line. It is used for things like knowing where to
move forwards or backwards from when doing an C<L> or C<-> command.
C<$max> tells the debugger where the last line of the current file is. It's
=over 4
-=item * The outer part of the loop, starting at the C<CMD> label. This loop
+=item *
+
+The outer part of the loop, starting at the C<CMD> label. This loop
reads a command and then executes it.
-=item * The inner part of the loop, starting at the C<PIPE> label. This part
+=item *
+
+The inner part of the loop, starting at the C<PIPE> label. This part
is wholly contained inside the C<CMD> block and only executes a command.
Used to handle commands running inside a pager.
# ... and we got a line of command input ...
defined(
$cmd = &readline(
- "$pidprompt DB"
+ "$pidprompt $tid DB"
. ( '<' x $level )
. ( $#hist + 1 )
. ( '>' x $level ) . " "
)
{
+ share($cmd);
# ... try to execute the input as debugger commands.
# Don't stop running.
=head4 The null command
-A newline entered by itself means "re-execute the last command". We grab the
+A newline entered by itself means I<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
chomp($cmd); # get rid of the annoying extra newline
push( @hist, $cmd ) if length($cmd) > 1;
push( @truehist, $cmd );
+ share(@hist);
+ share(@truehist);
# This is a restart point for commands that didn't arrive
# via direct user input. It allows us to 'redo PIPE' to
@vars = split( ' ', $2 );
# If main::dumpvar isn't here, get it.
- do 'dumpvar.pl' unless defined &main::dumpvar;
+ do 'dumpvar.pl' || die $@ unless defined &main::dumpvar;
if ( defined &main::dumpvar ) {
# We got it. Turn off subroutine entry/exit messages
# All of these commands were remapped in perl 5.8.0;
# we send them off to the secondary dispatcher (see below).
- $cmd =~ /^([aAbBhilLMoOPvwW]\b|[<>\{]{1,2})\s*(.*)/so && do {
+ $cmd =~ /^([aAbBeEhilLMoOPvwW]\b|[<>\{]{1,2})\s*(.*)/so && do {
&cmd_wrapper( $1, $2, $line );
next CMD;
};
and next CMD;
# Load up dumpvar if we don't have it. If we can, that is.
- do 'dumpvar.pl' unless defined &main::dumpvar;
+ do 'dumpvar.pl' || die $@ unless defined &main::dumpvar;
defined &main::dumpvar
or print $OUT "dumpvar.pl not available.\n"
and next CMD;
=head4 C<n> - single step, but don't trace down into subs
Done by setting C<$single> to 2, which forces subs to execute straight through
-when entered (see X<DB::sub>). We also save the C<n> command in C<$laststep>,
+when entered (see C<DB::sub>). We also save the C<n> command in C<$laststep>,
so a null command knows what to re-execute.
=cut
=head4 C<s> - single-step, entering subs
-Sets C<$single> to 1, which causes X<DB::sub> to continue tracing inside
+Sets C<$single> to 1, which causes C<DB::sub> to continue tracing inside
subs. Also saves C<s> as C<$lastcmd>.
=cut
# 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
+ # preceding 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.
=head4 C<$rc I<pattern> $rc> - Search command history
Another command to manipulate C<@hist>: this one searches it with a pattern.
-If a command is found, it is placed in C<$cmd> and executed via <redo>.
+If a command is found, it is placed in C<$cmd> and executed via C<redo>.
=cut
=head4 C<|, ||> - pipe output through the pager.
-FOR C<|>, we save C<OUT> (the debugger's output filehandle) and C<STDOUT>
+For C<|>, we save C<OUT> (the debugger's output filehandle) and C<STDOUT>
(the program's standard output). For C<||>, we only save C<OUT>. We open a
pipe to the pager (restoring the output filehandles if this fails). If this
is the C<|> command, we also set up a C<SIGPIPE> handler which will simply
$onetimedumpDepth = undef;
}
elsif ( $term_pid == $$ ) {
- STDOUT->flush();
- STDERR->flush();
+ eval { # May run under miniperl, when not available...
+ STDOUT->flush();
+ STDERR->flush();
+ };
# XXX If this is the master pid, print a newline.
print $OUT "\n";
It also tracks the subroutine call depth by saving the current setting of
C<$single> in the C<@stack> package global; if this exceeds the value in
C<$deep>, C<sub> automatically turns on printing of the current depth by
-setting the 4 bit in C<$single>. In any case, it keeps the current setting
+setting the C<4> bit in C<$single>. In any case, it keeps the current setting
of stop/don't stop on entry to subs set as it currently is set.
=head3 C<caller()> support
=item * C<$subroutine>
-The subroutine name; C<'(eval)'> if an C<eval>().
+The subroutine name; C<(eval)> if an C<eval>().
=item * C<$hasargs>
=item * C<$bitmask>
-pragma information: subject to change between versions
+pragma information; subject to change between versions
=item * C<@DB::args>
=cut
sub sub {
+ # Do not use a regex in this subroutine -> results in corrupted memory
+ # See: [perl #66110]
+
+ # lock ourselves under threads
+ lock($DBGR);
# 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 ($sub eq 'threads::new' && $ENV{PERL5DB_THREADED}) {
+ print "creating new thread\n";
+ }
- # If the last ten characters are C'::AUTOLOAD', note we've traced
+ # If the last ten characters are '::AUTOLOAD', note we've traced
# into AUTOLOAD for $sub.
if ( length($sub) > 10 && substr( $sub, -10, 10 ) eq '::AUTOLOAD' ) {
- $al = " for $$sub";
+ $al = " for $$sub" if defined $$sub;
}
# We stack the stack pointer and then increment it to protect us
# 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.
- if ($assertion) {
- $assertion = 0;
- eval { @ret = &$sub; };
- if ($@) {
- print $OUT $@;
- $signal = 1 unless $warnassertions;
- }
- }
- else {
- @ret = &$sub;
- }
+ @ret = &$sub;
# Pop the single-step value back off the stack.
$single |= $stack[ $stack_depth-- ];
# Scalar context.
else {
- if ($assertion) {
- $assertion = 0;
- eval {
+ if ( defined wantarray ) {
- # Save the value if it's wanted at all.
- $ret = &$sub;
- };
- if ($@) {
- print $OUT $@;
- $signal = 1 unless $warnassertions;
- }
- $ret = undef unless defined wantarray;
- }
- else {
- if ( defined wantarray ) {
+ # Save the value if it's wanted at all.
+ $ret = &$sub;
+ }
+ else {
- # Save the value if it's wanted at all.
- $ret = &$sub;
- }
- else {
-
- # Void return, explicitly.
- &$sub;
- undef $ret;
- }
- } # if assertion
+ # Void return, explicitly.
+ &$sub;
+ undef $ret;
+ }
# Pop the single-step value off the stack.
$single |= $stack[ $stack_depth-- ];
} ## end else [ if (wantarray)
} ## end sub sub
+sub lsub : lvalue {
+
+ # lock ourselves under threads
+ lock($DBGR);
+
+ # 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 ($sub =~ /^threads::new$/ && $ENV{PERL5DB_THREADED}) {
+ print "creating new thread\n";
+ }
+
+ # 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;
+
+ # Pop the single-step value back off the stack.
+ $single |= $stack[ $stack_depth-- ];
+
+ # call the original lvalue 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,
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'.
+Note that trying to set the CommandSet to C<foobar> simply results in the
+5.8.0 command set being used, since there's no top-level entry for C<foobar>.
=cut
C<cmd_wrapper()> allows the debugger to switch command sets
depending on the value of the C<CommandSet> option.
-It tries to look up the command in the X<C<%set>> package-level I<lexical>
+It tries to look up the command in the C<%set> package-level I<lexical>
(which means external entities can't fiddle with it) and create the name of
the sub to call based on the value found in the hash (if it's there). I<All>
of the commands to be handled in a set have to be added to C<%set>; if they
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
+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 C<$filename_error> and sets it to the name of the file to be processed.
+
+=item *
-=item * Localizes the C<*dbline> glob and reassigns it to point to the file we want to process.
+Localizes the C<*dbline> glob and reassigns it to point to the file we want to process.
-=item * Calls the first function.
+=item *
-The first function works on the "current" (i.e., the one we changed to) file,
+Calls the first function.
+
+The first function works on the I<current> file (i.e., the one we changed to),
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.
+if it needs to. When the functions return, C<*dbline> is restored to point
+to the actual current file (the one we're executing in) and
+C<$filename_error> is restored to C<"">. This restores everything to
+the way it was before the second function was called at all.
See the comments in C<breakable_line> and C<breakable_line_in_file> for more
details.
$filename_error = '';
-=head3 breakable_line($from, $to) (API)
+=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
die "Line$pl $from$upto$filename_error not breakable\n";
} ## end sub breakable_line
-=head3 breakable_line_in_filename($file, $from, $to) (API)
+=head3 breakable_line_in_filename(file, from, to) (API)
Like C<breakable_line>, but look in another file.
$signal = 1;
}
+=head3 C<cmd_e> - threads
+
+Display the current thread id:
+
+ e
+
+This could be how (when implemented) to send commands to this thread id (e cmd)
+or that thread id (e tid cmd).
+
+=cut
+
+sub cmd_e {
+ my $cmd = shift;
+ my $line = shift;
+ unless (exists($INC{'threads.pm'})) {
+ print "threads not loaded($ENV{PERL5DB_THREADED})
+ please run the debugger with PERL5DB_THREADED=1 set in the environment\n";
+ } else {
+ my $tid = threads->tid;
+ print "thread id: $tid\n";
+ }
+} ## end sub cmd_e
+
+=head3 C<cmd_E> - list of thread ids
+
+Display the list of available thread ids:
+
+ E
+
+This could be used (when implemented) to send commands to all threads (E cmd).
+
+=cut
+
+sub cmd_E {
+ my $cmd = shift;
+ my $line = shift;
+ unless (exists($INC{'threads.pm'})) {
+ print "threads not loaded($ENV{PERL5DB_THREADED})
+ please run the debugger with PERL5DB_THREADED=1 set in the environment\n";
+ } else {
+ my $tid = threads->tid;
+ print "thread ids: ".join(', ',
+ map { ($tid == $_->tid ? '<'.$_->tid.'>' : $_->tid) } threads->list
+ )."\n";
+ }
+} ## end sub cmd_E
+
=head3 C<cmd_h> - help command (command)
Does the work of either
=over 4
-=item * Showing all the debugger help
+=item *
+
+Showing all the debugger help
-=item * Showing help for a specific command
+=item *
+
+Showing help for a specific command
=back
sub cmd_i {
my $cmd = shift;
my $line = shift;
- eval { require Class::ISA };
- if ($@) {
- &warn( $@ =~ /locate/
- ? "Class::ISA module not found - please install\n"
- : $@ );
- }
- else {
- ISA:
- foreach my $isa ( split( /\s+/, $line ) ) {
- $evalarg = $isa;
- ($isa) = &eval;
- no strict 'refs';
- print join(
- ', ',
- map { # snaffled unceremoniously from Class::ISA
- "$_"
- . (
- defined( ${"$_\::VERSION"} )
- ? ' ' . ${"$_\::VERSION"}
- : undef )
- } Class::ISA::self_and_super_path(ref($isa) || $isa)
- );
- print "\n";
- }
+ foreach my $isa ( split( /\s+/, $line ) ) {
+ $evalarg = $isa;
+ ($isa) = &eval;
+ no strict 'refs';
+ print join(
+ ', ',
+ map {
+ "$_"
+ . (
+ defined( ${"$_\::VERSION"} )
+ ? ' ' . ${"$_\::VERSION"}
+ : undef )
+ } @{mro::get_linear_isa(ref($isa) || $isa)}
+ );
+ print "\n";
}
} ## end sub cmd_i
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.
+the I<watching expressions> bit.
=cut
These are general support routines that are used in a number of places
throughout the debugger.
-=item cmd_P
-
-Something to do with assertions
-
-=cut
-
-sub cmd_P {
- unless ($ini_assertion) {
- print $OUT "Assertions not supported in this Perl interpreter\n";
- } else {
- 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;
- }
-}
-
=head2 save
save() saves the user's versions of globals that would mess us up in C<@saved>,
C<dumpit()> then checks to see if it needs to load C<dumpvar.pl> and
tries to load it (note: if you have a C<dumpvar.pl> ahead of the
-installed version in @INC, yours will be used instead. Possible security
+installed version in C<@INC>, yours will be used instead. Possible security
problem?).
It then checks to see if the subroutine C<main::dumpValue> is now defined
# Load dumpvar.pl unless we've already got the sub we need from it.
unless ( defined &main::dumpValue ) {
- do 'dumpvar.pl';
+ do 'dumpvar.pl' or die $@;
}
# If the load succeeded (or we already had dumpvalue()), go ahead
=over 4
-=item * The filehandle to print to.
+=item *
+
+The filehandle to print to.
+
+=item *
+
+How many frames to skip before starting trace.
-=item * How many frames to skip before starting trace.
+=item *
-=item * How many frames to print.
+How many frames to print.
-=item * A flag: if true, print a "short" trace without filenames, line numbers, or arguments
+=item *
+
+A flag: if true, print a I<short> trace without filenames, line numbers, or arguments
=back
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
+Of note is the definition of the C<$balanced_brace_re> global via C<||=>, 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.
C<gets()> is a primitive (very primitive) routine to read continuations.
It was devised for reading continuations for actions.
-it just reads more input with X<C<readline()>> and returns it.
+it just reads more input with C<readline()> and returns it.
=cut
# 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 $@;
+ require Term::ReadLine;
# If noTTY is set, but we have a TTY name, go ahead and hook up to it.
if ($notty) {
# We don't have a TTY - try to find one via Term::Rendezvous.
else {
- eval "require Term::Rendezvous;" or die;
+ require Term::Rendezvous;
# See if we have anything to pass to Term::Rendezvous.
- # Use /tmp/perldbtty$$ if not.
- my $rv = $ENV{PERLDB_NOTTY} || "/tmp/perldbtty$$";
+ # Use $HOME/.perldbtty$$ if not.
+ my $rv = $ENV{PERLDB_NOTTY} || "$ENV{HOME}/.perldbtty$$";
# Rendezvous and get the filehandles.
- my $term_rv = new Term::Rendezvous $rv;
+ my $term_rv = Term::Rendezvous->new( $rv );
$IN = $term_rv->IN;
$OUT = $term_rv->OUT;
} ## end else [ if ($tty)
# If we shouldn't use Term::ReadLine, don't.
if ( !$rl ) {
- $term = new Term::ReadLine::Stub 'perldb', $IN, $OUT;
+ $term = Term::ReadLine::Stub->new( 'perldb', $IN, $OUT );
}
# We're using Term::ReadLine. Get all the attributes for this terminal.
else {
- $term = new Term::ReadLine 'perldb', $IN, $OUT;
+ $term = Term::ReadLine->new( 'perldb', $IN, $OUT );
$rl_attribs = $term->Attribs;
$rl_attribs->{basic_word_break_characters} .= '-:+/*,[])}'
$term->MinLine(2);
+ &load_hist();
+
if ( $term->Features->{setHistory} and "@hist" ne "?" ) {
$term->SetHistory(@hist);
}
$term_pid = $$;
} ## end sub setterm
+sub load_hist {
+ $histfile //= option_val("HistFile", undef);
+ return unless defined $histfile;
+ open my $fh, "<", $histfile or return;
+ local $/ = "\n";
+ @hist = ();
+ while (<$fh>) {
+ chomp;
+ push @hist, $_;
+ }
+ close $fh;
+}
+
+sub save_hist {
+ return unless defined $histfile;
+ eval { require File::Path } or return;
+ eval { require File::Basename } or return;
+ File::Path::mkpath(File::Basename::dirname($histfile));
+ open my $fh, ">", $histfile or die "Could not open '$histfile': $!";
+ $histsize //= option_val("HistSize",100);
+ my @copy = grep { $_ ne '?' } @hist;
+ my $start = scalar(@copy) > $histsize ? scalar(@copy)-$histsize : 0;
+ for ($start .. $#copy) {
+ print $fh "$copy[$_]\n";
+ }
+ close $fh or die "Could not write '$histfile': $!";
+}
+
=head1 GET_FORK_TTY EXAMPLE FUNCTIONS
When the process being debugged forks, or the process invokes a command
TTY (and probably another window) and to direct the new debugger to read and
write there.
-The debugger provides C<get_fork_TTY> functions which work for X Windows and
-OS/2. Other systems are not supported. You are encouraged to write
-C<get_fork_TTY> functions which work for I<your> platform and contribute them.
+The debugger provides C<get_fork_TTY> functions which work for TCP
+socket servers, X Windows, OS/2, and Mac OS X. Other systems are not
+supported. You are encouraged to write C<get_fork_TTY> functions which
+work for I<your> platform and contribute them.
+
+=head3 C<socket_get_fork_TTY>
+
+=cut
+
+sub connect_remoteport {
+ require IO::Socket;
+
+ my $socket = IO::Socket::INET->new(
+ Timeout => '10',
+ PeerAddr => $remoteport,
+ Proto => 'tcp',
+ );
+ if ( ! $socket ) {
+ die "Unable to connect to remote host: $remoteport\n";
+ }
+ return $socket;
+}
+
+sub socket_get_fork_TTY {
+ $tty = $LINEINFO = $IN = $OUT = connect_remoteport();
+
+ # Do I need to worry about setting $term?
+
+ reset_IN_OUT( $IN, $OUT );
+ return '';
+}
=head3 C<xterm_get_fork_TTY>
$pidprompt = ''; # Shown anyway in titlebar
+ # We need $term defined or we can not switch to the newly created xterm
+ if ($tty ne '' && !defined $term) {
+ require Term::ReadLine;
+ if ( !$rl ) {
+ $term = Term::ReadLine::Stub->new( 'perldb', $IN, $OUT );
+ }
+ else {
+ $term = Term::ReadLine->new( 'perldb', $IN, $OUT );
+ }
+ }
# There's our new TTY.
return $tty;
} ## end sub xterm_get_fork_TTY
=cut
# This example function resets $IN, $OUT itself
-sub os2_get_fork_TTY {
- local $^F = 40; # XXXX Fixme!
+my $c_pipe = 0;
+sub os2_get_fork_TTY { # A simplification of the following (and works without):
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;
+ my %opt = ( title => "Daughter Perl debugger $pids $name",
+ ($rl ? (read_by_key => 1) : ()) );
+ require OS2::Process;
+ my ($in, $out, $pid) = eval { OS2::Process::io_term(related => 0, %opt) }
+ or return;
+ $pidprompt = ''; # Shown anyway in titlebar
+ reset_IN_OUT($in, $out);
+ $tty = '*reset*';
+ return ''; # Indicate that reset_IN_OUT is called
+} ## end sub os2_get_fork_TTY
- if (
- pipe $in1, $out1
- and pipe $in2, $out2
+=head3 C<macosx_get_fork_TTY>
- # system P_SESSION will fail if there is another process
- # in the same session with a "dependent" asynchronous child session.
- and @args = (
- $rl, fileno $in1, fileno $out2, "Daughter Perl debugger $pids $name"
- )
- and (
- ( $kpid = CORE::system 4, $^X, '-we',
- <<'ES', @args ) >= 0 # P_SESSION
-END {sleep 5 unless $loaded}
-BEGIN {open STDIN, '</dev/con' or warn "reopen stdin: $!"}
-use OS2::Process;
-
-my ($rl, $in) = (shift, shift); # Read from $in and pass through
-set_title pop;
-system P_NOWAIT, $^X, '-we', <<EOS or die "Cannot start a grandkid";
- open IN, '<&=$in' or die "open <&=$in: \$!";
- \$| = 1; print while sysread IN, \$_, 1<<16;
-EOS
-
-my $out = shift;
-open OUT, ">&=$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
+The Mac OS X version uses AppleScript to tell Terminal.app to create
+a new window.
+
+=cut
+
+# Notes about Terminal.app's AppleScript support,
+# (aka things that might break in future OS versions).
+#
+# The "do script" command doesn't return a reference to the new window
+# it creates, but since it appears frontmost and windows are enumerated
+# front to back, we can use "first window" === "window 1".
+#
+# Since "do script" is implemented by supplying the argument (plus a
+# return character) as terminal input, there's a potential race condition
+# where the debugger could beat the shell to reading the command.
+# To prevent this, we wait for the screen to clear before proceeding.
+#
+# 10.3 and 10.4:
+# There's no direct accessor for the tty device name, so we fiddle
+# with the window title options until it says what we want.
+#
+# 10.5:
+# There _is_ a direct accessor for the tty device name, _and_ there's
+# a new possible component of the window title (the name of the settings
+# set). A separate version is needed.
+
+my @script_versions=
+
+ ([237, <<'__LEOPARD__'],
+tell application "Terminal"
+ do script "clear;exec sleep 100000"
+ tell first tab of first window
+ copy tty to thetty
+ set custom title to "forked perl debugger"
+ set title displays custom title to true
+ repeat while (length of first paragraph of (get contents)) > 0
+ delay 0.1
+ end repeat
+ end tell
+end tell
+thetty
+__LEOPARD__
+
+ [100, <<'__JAGUAR_TIGER__'],
+tell application "Terminal"
+ do script "clear;exec sleep 100000"
+ tell first window
+ set title displays shell path to false
+ set title displays window size to false
+ set title displays file name to false
+ set title displays device name to true
+ set title displays custom title to true
+ set custom title to ""
+ copy "/dev/" & name to thetty
+ set custom title to "forked perl debugger"
+ repeat while (length of first paragraph of (get contents)) > 0
+ delay 0.1
+ end repeat
+ end tell
+end tell
+thetty
+__JAGUAR_TIGER__
+
+);
+
+sub macosx_get_fork_TTY
+{
+ my($version,$script,$pipe,$tty);
+
+ return unless $version=$ENV{TERM_PROGRAM_VERSION};
+ foreach my $entry (@script_versions) {
+ if ($version>=$entry->[0]) {
+ $script=$entry->[1];
+ last;
+ }
+ }
+ return unless defined($script);
+ return unless open($pipe,'-|','/usr/bin/osascript','-e',$script);
+ $tty=readline($pipe);
+ close($pipe);
+ return unless defined($tty) && $tty =~ m(^/dev/);
+ chomp $tty;
+ return $tty;
+}
=head2 C<create_IN_OUT($flags)>
EOP
print_help(<<EOP);
- I know how to switch the output to a different window in xterms
- and OS/2 consoles only. For a manual switch, put the name of the created I<TTY>
- in B<\$DB::fork_TTY>, or define a function B<DB::get_fork_TTY()> returning this.
+ I know how to switch the output to a different window in xterms, OS/2
+ consoles, and Mac OS X Terminal.app only. For a manual switch, put the name
+ of the created I<TTY> in B<\$DB::fork_TTY>, or define a function
+ B<DB::get_fork_TTY()> returning this.
On I<UNIX>-like systems one can get the name of a I<TTY> for the given window
by typing B<tty>, and disconnect the I<shell> from I<TTY> by B<sleep 1000000>.
$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.
+ $stuff;
+ my $stuff = '';
+ my $buf;
+ do {
+ $IN->recv( $buf = '', 2048 ); # XXX "what's wrong with sysread?"
+ # XXX Don't know. You tell me.
+ } while length $buf and ($stuff .= $buf) !~ /\n/;
# What we got.
$stuff;
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)
+An option entered by itself is assumed to be I<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? ').
+value or to query the current value (via C<option? >).
-If 'option=value' is entered, we try to extract a quoted string from the
+If C<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
local \$doret = -2;
require '$optionRequire{$option}';
1;
- } || die # XXX: shouldn't happen
+ } || die $@ # XXX: shouldn't happen
if defined $optionRequire{$option}
&& defined $val;
The C<catch()> subroutine is the essence of fast and low-impact. We simply
set an already-existing global scalar variable to a constant value. This
avoids allocating any memory possibly in the middle of something that will
-get all confused if we do.
+get all confused if we do, particularly under I<unsafe signals>.
=cut
=cut
sub TTY {
+
if ( @_ and $term and $term->Features->{newTTY} ) {
# This terminal supports switching to a new TTY.
=head2 C<ReadLine>
Sets the C<$rl> option variable. If 0, we use C<Term::ReadLine::Stub>
-(essentially, no C<readline> processing on this "terminal"). Otherwise, we
+(essentially, no C<readline> processing on this I<terminal>). Otherwise, we
use C<Term::ReadLine>. Can't be changed after a terminal's in place; we save
the value in case a restart is done so we can change it then.
expand_DollarCaretP_flags($^P);
}
-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;
-}
-
=head2 C<pager>
Set up the C<$pager> variable. Adds a pipe to the front unless there's one
=head2 C<list_modules>
For the C<M> command: list modules loaded and their versions.
-Essentially just runs through the keys in %INC, picks up the
-$VERSION package globals from each package, gets the file name, and formats the
-information for output.
+Essentially just runs through the keys in %INC, picks each package's
+C<$VERSION> variable, gets the file name, and formats the information
+for output.
=cut
=head3 HELP MESSAGE FORMAT
-The help message is a peculiar format unto itself; it mixes C<pod> 'ornaments'
-(BE<lt>E<gt>, IE<gt>E<lt>) with tabs to come up with a format that's fairly
+The help message is a peculiar format unto itself; it mixes C<pod> I<ornaments>
+(C<< B<> >> C<< I<> >>) with tabs to come up with a format that's fairly
easy to parse and portable, but which still allows the help to be a little
nicer than just plain text.
-Essentially, you define the command name (usually marked up with BE<gt>E<lt>
-and IE<gt>E<lt>), followed by a tab, and then the descriptive text, ending in a newline. The descriptive text can also be marked up in the same way. If you
-need to continue the descriptive text to another line, start that line with
+Essentially, you define the command name (usually marked up with C<< B<> >>
+and C<< I<> >>), followed by a tab, and then the descriptive text, ending in a
+newline. The descriptive text can also be marked up in the same way. If you
+need to continue the descriptive text to another line, start that line with
just tabs and then enter the marked-up text.
If you are modifying the help text, I<be careful>. The help-string parser is
B<m> I<class> Prints methods callable via the given class.
B<M> Show versions of loaded modules.
B<i> I<class> Prints nested parents of given class.
+B<e> Display current thread id.
+B<E> Display all thread ids the current one will be identified: <n>.
B<y> [I<n> [I<Vars>]] List lexicals in higher scope <n>. Vars same as B<V>.
-B<P> Something to do with assertions...
B<<> ? List Perl commands to run before each prompt.
B<<> I<expr> Define Perl command to run before each prompt.
B<o> [I<opt>] ... Set boolean option to true
B<o> [I<opt>B<?>] Query options
B<o> [I<opt>B<=>I<val>] [I<opt>=B<\">I<val>B<\">] ...
- Set options. Use quotes in spaces in value.
+ Set options. Use quotes if spaces in value.
I<recallCommand>, I<ShellBang> chars used to recall command or spawn shell;
I<pager> program for output of \"|cmd\";
I<tkRunning> run Tk while prompting (with ReadLine);
B<V> [I<Pk> [I<Vars>]] List Variables in Package. Vars can be ~pattern or !pattern.
B<X> [I<Vars>] Same as \"B<V> I<current_package> [I<Vars>]\". B<i> I<class> inheritance tree.
B<y> [I<n> [I<Vars>]] List lexicals in higher scope <n>. Vars same as B<V>.
+ B<e> Display thread id B<E> Display all thread ids.
For more help, type B<h> I<cmd_letter>, or run B<$doccmd perldebug> for all docs.
END_SUM
B<O> [I<opt>] ... Set boolean option to true
B<O> [I<opt>B<?>] Query options
B<O> [I<opt>B<=>I<val>] [I<opt>=B<\">I<val>B<\">] ...
- Set options. Use quotes in spaces in value.
+ Set options. Use quotes if spaces in value.
I<recallCommand>, I<ShellBang> chars used to recall command or spawn shell;
I<pager> program for output of \"|cmd\";
I<tkRunning> run Tk while prompting (with ReadLine);
Most of what C<print_help> does is just text formatting. It finds the
C<B> and C<I> ornaments, cleans them off, and substitutes the proper
terminal control characters to simulate them (courtesy of
-<Term::ReadLine::TermCap>).
+C<Term::ReadLine::TermCap>).
=cut
This routine does a lot of gyrations to be sure that the pager is C<less>.
It checks for C<less> masquerading as C<more> and records the result in
-C<$ENV{LESS}> so we don't have to go through doing the stats again.
+C<$fixed_less> so we don't have to go through doing the stats again.
=cut
sub fix_less {
+ my $config_less = eval {
+ require Config;
+ $Config::Config{less};
+ };
+ return $config_less if $config_less;
+
# We already know if this is set.
- return if defined $ENV{LESS} && $ENV{LESS} =~ /r/;
+ return if $fixed_less;
# Pager is less for sure.
my $is_less = $pager =~ /\bless\b/;
# changes environment!
# 'r' added so we don't do (slow) stats again.
- $ENV{LESS} .= 'r' if $is_less;
+ $fixed_less = 1 if $is_less;
} ## end sub fix_less
=head1 DIE AND WARN MANAGEMENT
}
elsif ($prevwarn) {
$SIG{__WARN__} = $prevwarn;
+ } else {
+ undef $SIG{__WARN__};
}
} ## end if (@_)
$warnLevel;
elsif ($prevdie) {
$SIG{__DIE__} = $prevdie;
print $OUT "Default die handler restored.\n";
+ } else {
+ undef $SIG{__DIE__};
+ print $OUT "Die handler removed.\n";
}
} ## end if (@_)
$dieLevel;
=head2 C<CvGV_name()>
-Wrapper for X<CvGV_name_or_bust>; tries to get the name of a reference
+Wrapper for C<CvGV_name_or_bust>; tries to get the name of a reference
via that routine. If this fails, return the reference again (when the
-reference is stringified, it'll come out as "SOMETHING(0X...)").
+reference is stringified, it'll come out as C<SOMETHING(0x...)>).
=cut
C<undef> if L<Devel::Peek> can't be loaded, or if C<Devel::Peek::CvGV> can't
find a glob for this ref.
-Returns "I<package>::I<glob name>" if the code ref is found in a glob.
+Returns C<< I<package>::I<glob name> >> if the code ref is found in a glob.
=cut
A utility routine used in various places; finds the file where a subroutine
was defined, and returns that filename and a line-number range.
-Tries to use X<@sub> first; if it can't find it there, it tries building a
-reference to the subroutine and uses X<CvGV_name_or_bust> to locate it,
-loading it into X<@sub> as a side effect (XXX I think). If it can't find it
-this way, it brute-force searches X<%sub>, checking for identical references.
+Tries to use C<@sub> first; if it can't find it there, it tries building a
+reference to the subroutine and uses C<CvGV_name_or_bust> to locate it,
+loading it into C<@sub> as a side effect (XXX I think). If it can't find it
+this way, it brute-force searches C<%sub>, checking for identical references.
=cut
=head2 C<methods>
-A subroutine that uses the utility function X<methods_via> to find all the
+A subroutine that uses the utility function C<methods_via> to find all the
methods in the class corresponding to the current reference and in
C<UNIVERSAL>.
# This is a package that is contributing the methods we're about to print.
my $prefix = shift;
my $prepend = $prefix ? "via $prefix: " : '';
+ my @to_print;
+
+ # Extract from all the symbols in this class.
+ while (my ($name, $glob) = each %{"${class}::"}) {
+ # references directly in the symbol table are Proxy Constant
+ # Subroutines, and are by their very nature defined
+ # Otherwise, check if the thing is a typeglob, and if it is, it decays
+ # to a subroutine reference, which can be tested by defined.
+ # $glob might also be the value -1 (from sub foo;)
+ # or (say) '$$' (from sub foo ($$);)
+ # \$glob will be SCALAR in both cases.
+ if ((ref $glob || ($glob && ref \$glob eq 'GLOB' && defined &$glob))
+ && !$seen{$name}++) {
+ push @to_print, "$prepend$name\n";
+ }
+ }
- 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}::"}
- )
{
-
- # If we printed this already, skip it.
- next if $seen{$name}++;
-
- # Print the new method name.
- local $\ = '';
- local $, = '';
- print $DB::OUT "$prepend$name\n";
- } ## end for $name (grep { defined...
+ local $\ = '';
+ local $, = '';
+ print $DB::OUT $_ foreach sort @to_print;
+ }
# If the $crawl_upward argument is false, just quit here.
return unless shift;
=cut
sub setman {
- $doccmd = $^O !~ /^(?:MSWin32|VMS|os2|dos|amigaos|riscos|MacOS|NetWare)\z/s
+ $doccmd = $^O !~ /^(?:MSWin32|VMS|os2|dos|amigaos|riscos|NetWare)\z/s
? "man" # O Happy Day!
: "perldoc"; # Alas, poor unfortunates
} ## end sub setman
lexwarn
locale
lol
- machten
macos
macosx
- mint
modinstall
modlib
mod
os2
os390
os400
- othrtut
packtut
plan9
pod
=over 4
-=item * The debugger's own filehandles (copies of STD and STDOUT for now).
+=item *
+
+The debugger's own filehandles (copies of STD and STDOUT for now).
+
+=item *
+
+Characters for shell escapes, the recall command, and the history command.
+
+=item *
+
+The maximum recursion depth.
+
+=item *
+
+The size of a C<w> command's window.
-=item * Characters for shell escapes, the recall command, and the history command.
+=item *
-=item * The maximum recursion depth.
+The before-this-line context to be printed in a C<v> (view a window around this line) command.
-=item * The size of a C<w> command's window.
+=item *
-=item * The before-this-line context to be printed in a C<v> (view a window around this line) command.
+The fact that we're not in a sub at all right now.
-=item * The fact that we're not in a sub at all right now.
+=item *
-=item * The default SIGINT handler for the debugger.
+The default SIGINT handler for the debugger.
-=item * The appropriate value of the flag in C<$^D> that says the debugger is running
+=item *
-=item * The current debugger recursion level
+The appropriate value of the flag in C<$^D> that says the debugger is running
-=item * The list of postponed (XXX define) items and the C<$single> stack
+=item *
-=item * That we want no return values and no subroutine entry/exit trace.
+The current debugger recursion level
+
+=item *
+
+The list of postponed items and the C<$single> stack (XXX define this)
+
+=item *
+
+That we want no return values and no subroutine entry/exit trace.
=back
=over 4
-=item * Find all the subroutines that might match in this package
+=item *
+
+Find all the subroutines that might match in this package
+
+=item *
+
+Add C<postpone>, C<load>, and C<compile> as possibles (we may be completing the keyword itself)
+
+=item *
+
+Include all the rest of the subs that are known
-=item * Add "postpone", "load", and "compile" as possibles (we may be completing the keyword itself
+=item *
-=item * Include all the rest of the subs that are known
+C<grep> out the ones that match the text we have so far
-=item * C<grep> out the ones that match the text we have so far
+=item *
-=item * Return this as the list of possible completions
+Return this as the list of possible completions
=back
=head3 C<b load>
-Get all the possible files from @INC as it currently stands and
+Get all the possible files from C<@INC> as it currently stands and
select the ones that match the text so far.
=cut
=over 4
-=item * Determine the package that the symbol is in. Put it in C<::> (effectively C<main::>) if no package is specified.
+=item *
+
+Determine the package that the symbol is in. Put it in C<::> (effectively C<main::>) if no package is specified.
=cut
=pod
-=item * Figure out the prefix vs. what needs completing.
+=item *
+
+Figure out the prefix vs. what needs completing.
=cut
=pod
-=item * Look through all the symbols in the package. C<grep> out all the possible hashes/arrays/scalars, and then C<grep> the possible matches out of those. C<map> the prefix onto all the possibilities.
+=item *
+
+Look through all the symbols in the package. C<grep> out all the possible hashes/arrays/scalars, and then C<grep> the possible matches out of those. C<map> the prefix onto all the possibilities.
=cut
=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.
+=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
=cut
if ( $text =~ /^[\$@%]/ ) { # symbols (in $package + packages in main)
-
=pod
=over 4
-=item * If it's C<main>, delete main to just get C<::> leading.
+=item *
+
+If it's C<main>, delete main to just get C<::> leading.
=cut
=pod
-=item * We set the prefix to the item's sigil, and trim off the sigil to get the text to be completed.
+=item *
+
+We set the prefix to the item's sigil, and trim off the sigil to get the text to be completed.
=cut
$prefix = substr $text, 0, 1;
$text = substr $text, 1;
+ my @out;
+
+=pod
+
+=item *
+
+We look for the lexical scope above DB::DB and auto-complete lexical variables
+if PadWalker could be loaded.
+
+=cut
+
+ if (not $text =~ /::/ and eval { require PadWalker } ) {
+ my $level = 1;
+ while (1) {
+ my @info = caller($level);
+ $level++;
+ $level = -1, last
+ if not @info;
+ last if $info[3] eq 'DB::DB';
+ }
+ if ($level > 0) {
+ my $lexicals = PadWalker::peek_my($level);
+ push @out, grep /^\Q$prefix$text/, keys %$lexicals;
+ }
+ }
+
=pod
-=item * If the package is C<::> (C<main>), create an empty list; if it's something else, create a list of all the packages known. Append whichever list to a list of all the possible symbols in the current package. C<grep> out the matches to the text entered so far, then C<map> the prefix back onto the symbols.
+=item *
+
+If the package is C<::> (C<main>), create an empty list; if it's something else, create a list of all the packages known. Append whichever list to a list of all the possible symbols in the current package. C<grep> out the matches to the text entered so far, then C<map> the prefix back onto the symbols.
=cut
- my @out = map "$prefix$_", grep /^\Q$text/,
+ push @out, map "$prefix$_", grep /^\Q$text/,
( grep /^_?[a-zA-Z]/, keys %$pack ),
( $pack eq '::' ? () : ( grep /::$/, keys %:: ) );
-=item * If there's only one hit, it's a package qualifier, and it's not equal to the initial text, recomplete using this symbol.
+=item *
+
+If there's only one hit, it's a package qualifier, and it's not equal to the initial text, recomplete using this symbol.
=back
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
+ PERLDBf_SAVESRC => 0x400, # Save source lines into @{"_<$filename"}
+ PERLDB_ALL => 0x33f, # No _NONAME, _GOTO
);
+ # PERLDBf_LINE also enables the actions of PERLDBf_SAVESRC, so the debugger
+ # doesn't need to set it. It's provided for the benefit of profilers and
+ # other code analysers.
%DollarCaretP_flags_r = reverse %DollarCaretP_flags;
}
return @bits ? join( '|', @bits ) : 0;
}
+=over 4
+
=item rerun
Rerun the current session to:
# If warn was on before, turn it on again.
push @flags, '-w' if $ini_warn;
- if ( $ini_assertion and @{^ASSERTING} ) {
- push @flags,
- ( map { /\:\^\(\?\:(.*)\)\$\)/ ? "-A$1" : "-A$_" }
- @{^ASSERTING} );
- }
# Rebuild the -I flags that were on the initial
# command line.
}; # end restart
+=back
+
=head1 END PROCESSING - THE C<END> BLOCK
Come here at the very end of processing. We want to go into a
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).
-We then call C<DB::fake::at_exit()>, which returns the C<Use 'q' to quit ...">
+We then call C<DB::fake::at_exit()>, which returns the C<Use 'q' to quit ...>
message and returns control to the debugger. Repeat.
When the user finally enters a C<q> command, C<$fall_off_end> is set to
$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;
+ if ($fall_off_end or $runnonstop) {
+ &save_hist();
+ } else {
+ $DB::single = 1;
+ DB::fake::at_exit();
+ }
} ## end END
=head1 PRE-5.8 COMMANDS
=head2 Null command
-Does nothing. Used to 'turn off' commands.
+Does nothing. Used to I<turn off> commands.
=cut
=head2 C<cmd_prepost>
-Actually does all the handling foe C<E<lt>>, C<E<gt>>, C<{{>, C<{>, etc.
+Actually does all the handling for C<E<lt>>, C<E<gt>>, C<{{>, C<{>, etc.
Since the lists of actions are all held in arrays that are pointed to by
references anyway, all we have to do is pick the right array reference and
then use generic code to all, delete, or list actions.
https://perl5.git.perl.org / perl5.git / blobdiff