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 substitution 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;
};
$cmd =~ /^(enable|disable)\s+(\S+)\s*$/ && do {
my ($cmd, $position) = ($1, $2);
my ($fn, $line_num);
if ($position =~ m{\A\d+\z})
{
$fn = $filename;
$line_num = $position;
}
elsif ($position =~ m{\A(.*):(\d+)\z})
{
($fn, $line_num) = ($1, $2);
}
else
{
&warn("Wrong spec for enable/disable argument.\n");
}
if (defined($fn)) {
if (_has_breakpoint_data_ref($fn, $line_num)) {
_set_breakpoint_enabled_status($fn, $line_num,
($cmd eq 'enable' ? 1 : '')
);
}
else {
&warn("No breakpoint set at ${fn}:${line_num}\n");
}
}
next CMD;
};
=head4 C - send current history to a file
Takes the complete history, (not the shrunken version you see with C),
and saves it to the given filename, so it can be replayed using C.
Note that all C<^(save|source)>'s are commented out with a view to minimise recursion.
=cut
# save source - write commands to a file for later use
$cmd =~ /^save\s*(.*)$/ && do {
my $file = $1 || '.perl5dbrc'; # default?
if ( open my $fh, "> $file" ) {
# chomp to remove extraneous newlines from source'd files
chomp( my @truelist =
map { m/^\s*(save|source)/ ? "#$_" : $_ }
@truehist );
print $fh join( "\n", @truelist );
print "commands saved in $file\n";
}
else {
&warn("Can't save debugger commands in '$1': $!\n");
}
next CMD;
};
=head4 C - restart
Restart the debugger session.
=head4 C - rerun the current session
Return to any given position in the B-history list
=cut
# R - restart execution.
# rerun - controlled restart execution.
$cmd =~ /^(R|rerun\s*(.*))$/ && do {
my @args = ($1 eq 'R' ? restart() : rerun($2));
# Close all non-system fds for a clean restart. A more
# correct method would be to close all fds that were not
# open when the process started, but this seems to be
# hard. See "debugger 'R'estart and open database
# connections" on p5p.
my $max_fd = 1024; # default if POSIX can't be loaded
if (eval { require POSIX }) {
eval { $max_fd = POSIX::sysconf(POSIX::_SC_OPEN_MAX()) };
}
if (defined $max_fd) {
foreach ($^F+1 .. $max_fd-1) {
next unless open FD_TO_CLOSE, "<&=$_";
close(FD_TO_CLOSE);
}
}
# And run Perl again. We use exec() to keep the
# PID stable (and that way $ini_pids is still valid).
exec(@args) || print $OUT "exec failed: $!\n";
last 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+(\d+)?/\$DB::trace |= 1;\n/ && do {
$trace_to_depth = $1 ? $stack_depth||0 + $1 : 1E9;
};
# 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 == $$ ) {
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";
}
} ## 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 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 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