=item * 8 - Adds parameter information to messages, and overloaded stringify and tied FETCH is enabled on the printed arguments. Ignored if C<4> is not on.
-=item * 16 - Adds C<I<context> return from I<subname>: I<value>> messages on subroutine/eval exit. Ignored if C<4> is is not on.
+=item * 16 - Adds C<I<context> return from I<subname>: I<value>> messages on subroutine/eval exit. Ignored if C<4> is not on.
=back
use strict;
+use Cwd ();
+
+my $_initial_cwd;
+
BEGIN {eval 'use IO::Handle'}; # Needed for flush only? breaks under miniperl
BEGIN {
require feature;
$^V =~ /^v(\d+\.\d+)/;
feature->import(":$1");
+ $_initial_cwd = Cwd::getcwd();
}
# Debugger for Perl 5.00x; perl5db.pl patch level:
use vars qw($VERSION $header);
-$VERSION = '1.39_05';
+$VERSION = '1.46';
$header = "perl5db.pl version $VERSION";
# Since we're only saving $@, we only have to localize the array element
# that it will be stored in.
local $saved[0]; # Preserve the old value of $@
- eval { DB::save() };
+ eval { &DB::save };
# Now see whether we need to report an error back to the user.
if ($at) {
{
*get_fork_TTY = \&xterm_get_fork_TTY; # use the xterm version
}
+ elsif ( $ENV{TMUX} ) {
+ *get_fork_TTY = \&tmux_get_fork_TTY;
+ }
elsif ( $^O eq 'os2' ) { # If this is OS/2,
*get_fork_TTY = \&os2_get_fork_TTY; # use the OS/2 version
}
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_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
our ($runnonstop);
+# Local autoflush to avoid rt#116769,
+# as calling IO::File methods causes an unresolvable loop
+# that results in debugger failure.
+sub _autoflush {
+ my $o = select($_[0]);
+ $|++;
+ select($o);
+}
+
if ($notty) {
$runnonstop = 1;
share($runnonstop);
undef $console;
}
-=item * Unix - use C</dev/tty>.
+=item * Unix - use F</dev/tty>.
=cut
Several other systems don't use a specific console. We C<undef $console>
for those (Windows using a slave editor/graphical debugger, NetWare, OS/2
-with a slave editor, Epoc).
+with a slave editor).
=cut
$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.
} ## end elsif (from if(defined $remoteport))
# Unbuffer DB::OUT. We need to see responses right away.
- $OUT->autoflush(1);
+ _autoflush($OUT);
# Line info goes to debugger output unless pointed elsewhere.
# Pointing elsewhere makes it possible for slave editors to
use vars qw(
$action
$cmd
- $fall_off_end
$file
$filename_ini
$finished
%alias,
$doret,
$end,
+ $fall_off_end,
$incr,
$laststep,
$rc,
# see if we should stop. If so, remove the one-time sigil.
elsif ($stop) {
$evalarg = "\$DB::signal |= 1 if do {$stop}";
- DB::eval();
+ # The &-call is here to ascertain the mutability of @_.
+ &DB::eval;
# If the breakpoint is temporary, then delete its enabled status.
if ($dbline{$line} =~ s/;9($|\0)/$1/) {
_cancel_breakpoint_temp_enabled_status($filename, $line);
setterm();
}
- # ... and it belogs to this PID or we get one for this PID ...
+ # ... and it belongs to this PID or we get one for this PID ...
if ($term_pid != $$) {
resetterm(1);
}
}
sub _DB__trim_command_and_return_first_component {
+ my ($obj) = @_;
+
$cmd =~ s/\A\s+//s; # trim annoying leading whitespace
$cmd =~ s/\s+\z//s; # trim annoying trailing whitespace
- $cmd =~ m{\A(\S*)};
- return $1;
+ my ($verb, $args) = $cmd =~ m{\A(\S*)\s*(.*)}s;
+
+ $obj->cmd_verb($verb);
+ $obj->cmd_args($args);
+
+ return;
}
sub _DB__handle_f_command {
- if (($file) = $cmd =~ /\Af\b\s*(.*)/) {
- $file =~ s/\s+$//;
+ my ($obj) = @_;
+ if ($file = $obj->cmd_args) {
# help for no arguments (old-style was return from sub).
if ( !$file ) {
print $OUT
my ($obj) = @_;
# . command.
- if ($cmd eq '.') {
+ if ($obj->_is_full('.')) {
$incr = -1; # stay at current line
# Reset everything to the old location.
my ($obj) = @_;
if (my ($match_level, $match_vars)
- = $cmd =~ /^y(?:\s+(\d*)\s*(.*))?$/) {
+ = $obj->cmd_args =~ /\A(?:(\d*)\s*(.*))?\z/) {
# See if we've got the necessary support.
if (!eval { require PadWalker; PadWalker->VERSION(0.08) }) {
my $Err = $@;
- DB::warn(
+ _db_warn(
$Err =~ /locate/
? "PadWalker module not found - please install\n"
: $Err
my @vars = split( ' ', $match_vars || '' );
# Find the pad.
- my $h = eval { PadWalker::peek_my( ( $match_level || 0 ) + 1 ) };
+ my $h = eval { PadWalker::peek_my( ( $match_level || 0 ) + 2 ) };
# Oops. Can't find it.
if (my $Err = $@) {
$Err =~ s/ at .*//;
- DB::warn($Err);
+ _db_warn($Err);
next CMD;
}
sub _DB__handle_c_command {
my ($obj) = @_;
- if (my ($new_i) = $cmd =~ m#\Ac\b\s*([\w:]*)\s*\z#) {
+ my $i = $obj->cmd_args;
- $obj->i_cmd($new_i);
+ if ($i =~ m#\A[\w:]*\z#) {
# Hey, show's over. The debugged program finished
# executing already.
next CMD if _DB__is_finished();
# Capture the place to put a one-time break.
- $subname = $obj->i_cmd;
+ $subname = $i;
# Probably not needed, since we finish an interactive
# sub-session anyway...
# to where the subroutine is defined; we call find_sub,
# break up the return value, and assign it in one
# operation.
- ( $file, $new_i ) = ( find_sub($subname) =~ /^(.*):(.*)$/ );
+ ( $file, $i ) = ( find_sub($subname) =~ /^(.*):(.*)$/ );
# Force the line number to be numeric.
- $obj->i_cmd($new_i + 0);
+ $i = $i + 0;
# If we got a line number, we found the sub.
- if ($obj->i_cmd) {
+ if ($i) {
# Switch all the debugger's internals around so
# we're actually working with that file.
# Scan forward to the first executable line
# after the 'sub whatever' line.
$max = $#dbline;
- my $ii = $obj->i_cmd;
- ++$ii while $dbline[$ii] == 0 && $ii < $max;
- $obj->i_cmd($ii);
+ my $_line_num = $i;
+ while ($dbline[$_line_num] == 0 && $_line_num< $max)
+ {
+ $_line_num++;
+ }
+ $i = $_line_num;
} ## end if ($i)
# We didn't find a sub by that name.
# On the gripping hand, we can't do anything unless the
# current value of $i points to a valid breakable line.
# Check that.
- if ($obj->i_cmd) {
+ if ($i) {
# Breakable?
- if ( $dbline[$obj->i_cmd] == 0 ) {
- print $OUT "Line " . $obj->i_cmd . " not breakable.\n";
+ if ( $dbline[$i] == 0 ) {
+ print $OUT "Line $i not breakable.\n";
next CMD;
}
# Yes. Set up the one-time-break sigil.
- $dbline{$obj->i_cmd} =~ s/($|\0)/;9$1/; # add one-time-only b.p.
- _enable_breakpoint_temp_enabled_status($filename, $obj->i_cmd);
+ $dbline{$i} =~ s/($|\0)/;9$1/; # add one-time-only b.p.
+ _enable_breakpoint_temp_enabled_status($filename, $i);
} ## end if ($i)
# Turn off stack tracing from here up.
- for my $i (0 .. $stack_depth) {
- $stack[ $i ] &= ~1;
+ for my $j (0 .. $stack_depth) {
+ $stack[ $j ] &= ~1;
}
last CMD;
}
# If the pattern isn't null ...
if ( $inpat ne "" ) {
- # Turn of warn and die procesing for a bit.
+ # Turn off warn and die processing for a bit.
local $SIG{__DIE__};
local $SIG{__WARN__};
# Oops. Bad pattern. No biscuit.
# Print the eval error and go back for more
# commands.
- print $OUT "$@";
+ print {$OUT} "$@";
next CMD;
}
$obj->pat($inpat);
++$start;
# Wrap if we pass the last line.
- $start = 1 if ($start > $max);
+ if ($start > $max) {
+ $start = 1;
+ }
# Stop if we have gotten back to this line again,
last if ($start == $end);
if ($dbline[$start] =~ m/$pat/i) {
if ($slave_editor) {
# Handle proper escaping in the slave.
- print $OUT "\032\032$filename:$start:0\n";
+ print {$OUT} "\032\032$filename:$start:0\n";
}
else {
# Just print the line normally.
- print $OUT "$start:\t",$dbline[$start],"\n";
+ print {$OUT} "$start:\t",$dbline[$start],"\n";
}
# And quit since we found something.
last;
sub _DB__handle_restart_and_rerun_commands {
my ($obj) = @_;
+ my $cmd_cmd = $obj->cmd_verb;
+ my $cmd_params = $obj->cmd_args;
# R - restart execution.
# rerun - controlled restart execution.
- if (my ($cmd_cmd, $cmd_params) =
- $cmd =~ /\A((?:R)|(?:rerun\s*(.*)))\z/) {
+ if ($cmd_cmd eq 'rerun' or $cmd_params eq '') {
+
+ # Change directory to the initial current working directory on
+ # the script startup, so if the debugged program changed the
+ # directory, then we will still be able to find the path to the
+ # the program. (perl 5 RT #121509 ).
+ chdir ($_initial_cwd);
+
my @args = ($cmd_cmd eq 'R' ? restart() : rerun($cmd_params));
# Close all non-system fds for a clean restart. A more
# Default pager is into a pipe. Redirect I/O.
open( SAVEOUT, ">&STDOUT" )
- || DB::warn("Can't save STDOUT");
+ || _db_warn("Can't save STDOUT");
open( STDOUT, ">&OUT" )
- || DB::warn("Can't redirect STDOUT");
+ || _db_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");
+ open( SAVEOUT, ">&OUT" ) || _db_warn("Can't save DB::OUT");
}
# Fix up environment to record we have less if so.
unless ( $obj->piped(scalar ( open( OUT, $pager ) ) ) ) {
# Couldn't open pipe to pager.
- DB::warn("Can't pipe output to '$pager'");
+ _db_warn("Can't pipe output to '$pager'");
if ( $pager =~ /^\|/ ) {
# Redirect I/O back again.
open( OUT, ">&STDOUT" ) # XXX: lost message
- || DB::warn("Can't restore DB::OUT");
+ || _db_warn("Can't restore DB::OUT");
open( STDOUT, ">&SAVEOUT" )
- || DB::warn("Can't restore STDOUT");
+ || _db_warn("Can't restore STDOUT");
close(SAVEOUT);
} ## end if ($pager =~ /^\|/)
else {
# Redirect I/O. STDOUT already safe.
open( OUT, ">&STDOUT" ) # XXX: lost message
- || DB::warn("Can't restore DB::OUT");
+ || _db_warn("Can't restore DB::OUT");
}
next CMD;
} ## end unless ($piped = open(OUT,...
if $pager =~ /^\|/
&& ( "" eq $SIG{PIPE} || "DEFAULT" eq $SIG{PIPE} );
- OUT->autoflush(1);
+ _autoflush(\*OUT);
# Save current filehandle, and put it back.
$obj->selected(scalar( select(OUT) ));
# Don't put it back if pager was a pipe.
# Reopen filehandle for our output (if we can) and
# restore STDOUT (if we can).
- open( OUT, ">&STDOUT" ) || &warn("Can't restore DB::OUT");
+ open( OUT, ">&STDOUT" ) || _db_warn("Can't restore DB::OUT");
open( STDOUT, ">&SAVEOUT" )
- || &warn("Can't restore STDOUT");
+ || _db_warn("Can't restore STDOUT");
# Turn off pipe exception handler if necessary.
$SIG{PIPE} = "DEFAULT" if $SIG{PIPE} eq \&DB::catch;
else {
# Non-piped "pager". Just restore STDOUT.
- open( OUT, ">&SAVEOUT" ) || &warn("Can't restore DB::OUT");
+ open( OUT, ">&SAVEOUT" ) || _db_warn("Can't restore DB::OUT");
}
+ # Let Readline know about the new filehandles.
+ reset_IN_OUT( \*IN, \*OUT );
+
# Close filehandle pager was using, restore the normal one
# if necessary,
close(SAVEOUT);
return;
}
+sub _DB__handle_watch_expressions
+{
+ my $self = shift;
+
+ if ( $DB::trace & 2 ) {
+ for my $n (0 .. $#DB::to_watch) {
+ $DB::evalarg = $DB::to_watch[$n];
+ local $DB::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( "', '", DB::eval(@_) );
+ $val = ( ( defined $val ) ? "'$val'" : 'undef' );
+
+ # Did it change?
+ if ( $val ne $DB::old_watch[$n] ) {
+
+ # Yep! Show the difference, and fake an interrupt.
+ $DB::signal = 1;
+ print {$DB::OUT} <<EOP;
+Watchpoint $n:\t$DB::to_watch[$n] changed:
+ old value:\t$DB::old_watch[$n]
+ new value:\t$val
+EOP
+ $DB::old_watch[$n] = $val;
+ } ## end if ($val ne $old_watch...
+ } ## end for my $n (0 ..
+ } ## end if ($trace & 2)
+
+ return;
+}
+
+# 't' is type.
+# 'm' is method.
+# 'v' is the value (i.e: method name or subroutine ref).
+# 's' is subroutine.
+my %cmd_lookup =
+(
+ '-' => { t => 'm', v => '_handle_dash_command', },
+ '.' => { t => 's', v => \&_DB__handle_dot_command, },
+ '=' => { t => 'm', v => '_handle_equal_sign_command', },
+ 'H' => { t => 'm', v => '_handle_H_command', },
+ 'S' => { t => 'm', v => '_handle_S_command', },
+ 'T' => { t => 'm', v => '_handle_T_command', },
+ 'W' => { t => 'm', v => '_handle_W_command', },
+ 'c' => { t => 's', v => \&_DB__handle_c_command, },
+ 'f' => { t => 's', v => \&_DB__handle_f_command, },
+ 'm' => { t => 's', v => \&_DB__handle_m_command, },
+ 'n' => { t => 'm', v => '_handle_n_command', },
+ 'p' => { t => 'm', v => '_handle_p_command', },
+ 'q' => { t => 'm', v => '_handle_q_command', },
+ 'r' => { t => 'm', v => '_handle_r_command', },
+ 's' => { t => 'm', v => '_handle_s_command', },
+ 'save' => { t => 'm', v => '_handle_save_command', },
+ 'source' => { t => 'm', v => '_handle_source_command', },
+ 't' => { t => 'm', v => '_handle_t_command', },
+ 'w' => { t => 'm', v => '_handle_w_command', },
+ 'x' => { t => 'm', v => '_handle_x_command', },
+ 'y' => { t => 's', v => \&_DB__handle_y_command, },
+ (map { $_ => { t => 'm', v => '_handle_V_command_and_X_command', }, }
+ ('X', 'V')),
+ (map { $_ => { t => 'm', v => '_handle_enable_disable_commands', }, }
+ qw(enable disable)),
+ (map { $_ =>
+ { t => 's', v => \&_DB__handle_restart_and_rerun_commands, },
+ } qw(R rerun)),
+ (map { $_ => {t => 'm', v => '_handle_cmd_wrapper_commands' }, }
+ qw(a A b B e E h i l L M o O v w W)),
+);
+
sub DB {
# lock the debugger and get the thread id for the prompt
$tid = eval { "[".threads->tid."]" };
}
- my $i;
+ my $cmd_verb;
+ my $cmd_args;
my $obj = DB::Obj->new(
{
after => \$after,
explicit_stop => \$explicit_stop,
infix => \$infix,
- i_cmd => \$i,
+ cmd_args => \$cmd_args,
+ cmd_verb => \$cmd_verb,
pat => \$pat,
piped => \$piped,
selected => \$selected,
# Preserve current values of $@, $!, $^E, $,, $/, $\, $^W.
# The code being debugged may have altered them.
- &save;
+ DB::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
# Last line in the program.
$max = $#dbline;
- _DB__determine_if_we_should_break(@_);
+ # The &-call is here to ascertain the mutability of @_.
+ &_DB__determine_if_we_should_break;
# Preserve the current stop-or-not, and see if any of the W
# (watch expressions) has changed.
my $was_signal = $signal;
# If we have any watch expressions ...
- $obj->_DB__handle_watch_expressions(@_);
+ _DB__handle_watch_expressions($obj);
=head2 C<watchfunction()>
# If there's an action, do it now.
if ($action) {
$evalarg = $action;
- DB::eval();
+ # The &-call is here to ascertain the mutability of @_.
+ &DB::eval;
}
# Are we nested another level (e.g., did we evaluate a function
# Do any pre-prompt actions.
foreach $evalarg (@$pre) {
- DB::eval();
+ # The &-call is here to ascertain the mutability of @_.
+ &DB::eval;
}
# Complain about too much recursion if we passed the limit.
# via direct user input. It allows us to 'redo PIPE' to
# re-execute command processing without reading a new command.
PIPE: {
- $i = _DB__trim_command_and_return_first_component();
+ _DB__trim_command_and_return_first_component($obj);
=head3 COMMAND ALIASES
=cut
# See if there's an alias for the command, and set it up if so.
- if ( $alias{$i} ) {
+ if ( $alias{$cmd_verb} ) {
# Squelch signal handling; we want to keep control here
# if something goes loco during the alias eval.
# 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}";
+ eval "\$cmd =~ $alias{$cmd_verb}";
if ($@) {
local $\ = '';
- print $OUT "Couldn't evaluate '$i' alias: $@";
+ print $OUT "Couldn't evaluate '$cmd_verb' alias: $@";
next CMD;
}
- } ## end if ($alias{$i})
+ _DB__trim_command_and_return_first_component($obj);
+ } ## end if ($alias{$cmd_verb})
=head3 MAIN-LINE COMMANDS
=cut
- if ($cmd eq 'q') {
- $fall_off_end = 1;
- clean_ENV();
- exit $?;
+ # All of these commands were remapped in perl 5.8.0;
+ # we send them off to the secondary dispatcher (see below).
+ $obj->_handle_special_char_cmd_wrapper_commands;
+ _DB__trim_command_and_return_first_component($obj);
+
+ if (my $cmd_rec = $cmd_lookup{$cmd_verb}) {
+ my $type = $cmd_rec->{t};
+ my $val = $cmd_rec->{v};
+ if ($type eq 'm') {
+ $obj->$val();
+ }
+ elsif ($type eq 's') {
+ $val->($obj);
+ }
}
=head4 C<t> - trace [n]
Turn tracing on or off. Inverts the appropriate bit in C<$trace> (q.v.).
If level is specified, set C<$trace_to_depth>.
-=cut
-
- $obj->_handle_t_command;
-
=head4 C<S> - list subroutines matching/not matching a pattern
Walks through C<%sub>, checking to see whether or not to print the name.
-=cut
-
- $obj->_handle_S_command;
-
=head4 C<X> - list variables in current package
Since the C<V> command actually processes this, just change this to the
Uses C<dumpvar.pl> to dump out the current values for selected variables.
-=cut
-
- $obj->_handle_V_command_and_X_command;
-
=head4 C<x> - evaluate and print an expression
Hands the expression off to C<DB::eval>, setting it up to print the value
via C<dumpvar.pl> instead of just printing it directly.
-=cut
-
- $obj->_handle_x_command;
-
=head4 C<m> - print methods
Just uses C<DB::methods> to determine what methods are available.
-=cut
-
- _DB__handle_m_command($obj);
-
=head4 C<f> - switch files
-=cut
-
- _DB__handle_f_command();
+Switch to a different filename.
=head4 C<.> - return to last-executed line.
We set C<$incr> to -1 to indicate that the debugger shouldn't move ahead,
and then we look up the line in the magical C<%dbline> hash.
-=cut
-
- _DB__handle_dot_command($obj);
-
=head4 C<-> - back one window
We change C<$start> to be one window back; if we go back past the first line,
currently-executing line, and then put a C<l $start +> (list one window from
C<$start>) in C<$cmd> to be executed later.
-=cut
-
- # - - back a window.
- $obj->_handle_dash_command;
-
=head3 PRE-580 COMMANDS VS. NEW COMMANDS: C<a, A, b, B, h, l, L, M, o, O, P, v, w, W, E<lt>, E<lt>E<lt>, E<0x7B>, E<0x7B>E<0x7B>>
In Perl 5.8.0, a realignment of the commands was done to fix up a number of
them. At this point, we check for the new commands and call C<cmd_wrapper> to
deal with them instead of processing them in-line.
-=cut
-
- # All of these commands were remapped in perl 5.8.0;
- # we send them off to the secondary dispatcher (see below).
- if (my ($cmd_letter, $my_arg) = $cmd =~ /\A([aAbBeEhilLMoOPvwW]\b|[<>\{]{1,2})\s*(.*)/so) {
- cmd_wrapper( $cmd_letter, $my_arg, $line );
- next CMD;
- }
-
=head4 C<y> - List lexicals in higher scope
Uses C<PadWalker> to find the lexicals supplied as arguments in a scope
above the current one and then displays then using C<dumpvar.pl>.
-=cut
-
- _DB__handle_y_command($obj);
-
=head3 COMMANDS NOT WORKING AFTER PROGRAM ENDS
All of the commands below this point don't work after the program being
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
-
- # n - next
- $obj->_handle_n_command;
-
=head4 C<s> - single-step, entering subs
Sets C<$single> to 1, which causes C<DB::sub> to continue tracing inside
subs. Also saves C<s> as C<$lastcmd>.
-=cut
-
- $obj->_handle_s_command;
-
=head4 C<c> - run continuously, setting an optional breakpoint
Most of the code for this command is taken up with locating the optional
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.
- _DB__handle_c_command($obj);
-
=head4 C<r> - return from a subroutine
For C<r> to work properly, the debugger has to stop execution again
we are printing return values when a C<r> is executed, set C<$doret>
appropriately, and force us out of the command loop.
-=cut
-
- # r - return from the current subroutine.
- $obj->_handle_r_command;
-
=head4 C<T> - stack trace
Just calls C<DB::print_trace>.
-=cut
-
- $obj->_handle_T_command;
-
=head4 C<w> - List window around current line.
Just calls C<DB::cmd_w>.
-=cut
-
- $obj->_handle_w_command;
-
=head4 C<W> - watch-expression processing.
Just calls C<DB::cmd_W>.
-=cut
-
- $obj->_handle_W_command;
-
=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
=head4 C<$rc> - Recall command
Manages the commands in C<@hist> (which is created if C<Term::ReadLine> reports
-that the terminal supports history). It find the the command required, puts it
+that the terminal supports history). It finds the command required, puts it
into C<$cmd>, and redoes the loop to execute it.
=cut
=head4 C<$sh$sh> - C<system()> command
-Calls the C<DB::system()> to handle the command. This keeps the C<STDIN> and
+Calls the C<_db_system()> to handle the command. This keeps the C<STDIN> and
C<STDOUT> from getting messed up.
=cut
=head4 C<$sh> - Invoke a shell
-Uses C<DB::system> to invoke a shell.
+Uses C<_db_system()> to invoke a shell.
=cut
=head4 C<$sh I<command>> - Force execution of a command in a shell
Like the above, but the command is passed to the shell. Again, we use
-C<DB::system> to avoid problems with C<STDIN> and C<STDOUT>.
+C<_db_system()> to avoid problems with C<STDIN> and C<STDOUT>.
=head4 C<H> - display commands in history
Prints the contents of C<@hist> (if any).
-=cut
-
- $obj->_handle_H_command;
-
=head4 C<man, doc, perldoc> - look up documentation
Just calls C<runman()> to print the appropriate document.
Builds a C<print EXPR> expression in the C<$cmd>; this will get executed at
the bottom of the loop.
-=cut
-
- $obj->_handle_p_command;
-
=head4 C<=> - define command alias
Manipulates C<%alias> to add or list command aliases.
-=cut
-
- # = - set up a command alias.
- $obj->_handle_equal_sign_command;
-
=head4 C<source> - read commands from a file.
Opens a lexical filehandle and stacks it on C<@cmdfhs>; C<DB::readline> will
pick it up.
-=cut
-
- $obj->_handle_source_command;
-
=head4 C<enable> C<disable> - enable or disable breakpoints
This enables or disables breakpoints.
-=cut
-
- $obj->_handle_enable_disable_commands;
-
=head4 C<save> - send current history to a file
Takes the complete history, (not the shrunken version you see with C<H>),
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
- $obj->_handle_save_command;
-
=head4 C<R> - restart
Restart the debugger session.
Return to any given position in the B<true>-history list
-=cut
-
- # R - restart execution.
- # rerun - controlled restart execution.
- _DB__handle_restart_and_rerun_commands($obj);
-
=head4 C<|, ||> - pipe output through the pager.
For C<|>, we save C<OUT> (the debugger's output filehandle) and C<STDOUT>
} # PIPE:
+ # trace an expression
+ $cmd =~ s/^t\s/\$DB::trace |= 1;\n/;
+
# 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.
- DB::eval();
+ # The &-call is here to ascertain the mutability of @_.
+ &DB::eval;
# Turn off the one-time-dump stuff now.
if ($onetimeDump) {
# Evaluate post-prompt commands.
foreach $evalarg (@$post) {
- DB::eval();
+ # The &-call is here to ascertain the mutability of @_.
+ &DB::eval;
}
} # if ($single || $signal)
();
} ## end sub DB
+# Because DB::Obj is used above,
+#
+# my $obj = DB::Obj->new(
+#
+# The following package declaration must come before that,
+# or else runtime errors will occur with
+#
+# PERLDB_OPTS="autotrace nonstop"
+#
+# ( rt#116771 )
+BEGIN {
+
package DB::Obj;
sub new {
{
no strict 'refs';
foreach my $slot_name (qw(
- after explicit_stop infix pat piped position prefix selected i_cmd
+ after explicit_stop infix pat piped position prefix selected cmd_verb
+ cmd_args
)) {
my $slot = $slot_name;
*{$slot} = sub {
return;
}
-sub _DB__handle_watch_expressions
-{
- my $self = shift;
-
- if ( $trace & 2 ) {
- for my $n (0 .. $#to_watch) {
- $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( "', '", DB::eval() );
- $val = ( ( defined $val ) ? "'$val'" : 'undef' );
-
- # Did it change?
- if ( $val ne $old_watch[$n] ) {
-
- # Yep! Show the difference, and fake an interrupt.
- $signal = 1;
- print {$OUT} <<EOP;
-Watchpoint $n:\t$to_watch[$n] changed:
- old value:\t$old_watch[$n]
- new value:\t$val
-EOP
- $old_watch[$n] = $val;
- } ## end if ($val ne $old_watch...
- } ## end for my $n (0 ..
- } ## end if ($trace & 2)
-
- return;
-}
-
sub _my_print_lineinfo
{
my ($self, $i, $incr_pos) = @_;
return $DB::dbline[$line];
}
+sub _is_full {
+ my ($self, $letter) = @_;
+
+ return ($DB::cmd eq $letter);
+}
+
sub _DB__grab_control
{
my $self = shift;
}
sub _handle_t_command {
- if (my ($levels) = $DB::cmd =~ /\At(?:\s+(\d+))?\z/) {
+ my $self = shift;
+
+ my $levels = $self->cmd_args();
+
+ if ((!length($levels)) or ($levels !~ /\D/)) {
$trace ^= 1;
local $\ = '';
$DB::trace_to_depth = $levels ? $stack_depth + $levels : 1E9;
sub _handle_S_command {
+ my $self = shift;
+
if (my ($print_all_subs, $should_reverse, $Spatt)
- = $DB::cmd =~ /\AS(\s+(!)?(.+))?\z/) {
+ = $self->cmd_args =~ /\A((!)?(.+))?\z/) {
# $Spatt is the pattern (if any) to use.
# Reverse scan?
my $Srev = defined $should_reverse;
}
sub _handle_V_command_and_X_command {
+ my $self = shift;
$DB::cmd =~ s/^X\b/V $DB::package/;
# Bare V commands get the currently-being-debugged package
# added.
- if ($DB::cmd eq "V") {
+ if ($self->_is_full('V')) {
$DB::cmd = "V $DB::package";
}
# must detect sigpipe failures - not catching
# then will cause the debugger to die.
eval {
- &main::dumpvar(
+ main::dumpvar(
$packname,
defined $option{dumpDepth}
? $option{dumpDepth}
}
sub _handle_dash_command {
+ my $self = shift;
- if ($DB::cmd eq '-') {
+ if ($self->_is_full('-')) {
# back up by a window; go to 1 if back too far.
$start -= $incr + $window + 1;
# Generate and execute a "l +" command (handled below).
$DB::cmd = 'l ' . ($start) . '+';
+ redo CMD;
}
return;
}
sub _n_or_s {
my ($self, $letter, $new_val) = @_;
- if ($DB::cmd eq $letter) {
+ if ($self->_is_full($letter)) {
$self->_n_or_s_commands_generic($new_val);
}
- elsif ($DB::cmd =~ m#\A\Q$letter\E\b#) {
+ else {
$self->_n_or_s_and_arg_commands_generic($letter, $new_val);
}
sub _handle_r_command {
my $self = shift;
+
# r - return from the current subroutine.
- if ($DB::cmd eq 'r') {
+ if ($self->_is_full('r')) {
# Can't do anything if the program's over.
next CMD if DB::_DB__is_finished();
}
sub _handle_T_command {
- if ($DB::cmd eq 'T') {
+ my $self = shift;
+
+ if ($self->_is_full('T')) {
DB::print_trace( $OUT, 1 ); # skip DB
next CMD;
}
}
sub _handle_w_command {
- if (my ($arg) = $DB::cmd =~ /\Aw\b\s*(.*)/s) {
- DB::cmd_w( 'w', $arg );
- next CMD;
- }
+ my $self = shift;
+
+ DB::cmd_w( 'w', $self->cmd_args() );
+ next CMD;
return;
}
sub _handle_W_command {
- if (my ($arg) = $DB::cmd =~ /\AW\b\s*(.*)/s) {
+ my $self = shift;
+
+ if (my $arg = $self->cmd_args) {
DB::cmd_W( 'W', $arg );
next CMD;
}
# 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.
- my $new_i = $minus ? ( $#hist - ( $arg || 1 ) ) : ( $arg || $#hist );
- $self->i_cmd($new_i);
+ $self->cmd_verb(
+ scalar($minus ? ( $#hist - ( $arg || 1 ) ) : ( $arg || $#hist ))
+ );
# Pick out the command desired.
- $DB::cmd = $hist[$self->i_cmd];
+ $DB::cmd = $hist[$self->cmd_verb];
# Print the command to be executed and restart the loop
# with that command in the buffer.
# Toss off last entry if length is >1 (and it always is).
pop(@hist) if length($DB::cmd) > 1;
- my $i = $self->i_cmd;
+ my $i;
# Look backward through the history.
SEARCH_HIST:
last SEARCH_HIST if $hist[$i] =~ /$pat/;
}
- $self->i_cmd($i);
-
- if ( !$self->i_cmd ) {
+ if ( !$i ) {
# Never found it.
print $OUT "No such command!\n\n";
}
# Found it. Put it in the buffer, print it, and process it.
- $DB::cmd = $hist[$self->i_cmd];
+ $DB::cmd = $hist[$i];
print $OUT $DB::cmd, "\n";
redo CMD;
}
sub _handle_H_command {
my $self = shift;
- if ($DB::cmd =~ /\AH\b\s*\*/) {
+ if ($self->cmd_args =~ m#\A\*#) {
@hist = @truehist = ();
print $OUT "History cleansed\n";
next CMD;
}
- if (my ($num)
- = $DB::cmd =~ /\AH\b\s*(?:-(\d+))?/) {
+ if (my ($num) = $self->cmd_args =~ /\A(?:-(\d+))?/) {
# Anything other than negative numbers is ignored by
# the (incorrect) pattern, so this test does nothing.
unless $hist[$i] =~ /^.?$/;
}
- $self->i_cmd($i);
-
next CMD;
}
# man, perldoc, doc - show manual pages.
if (my ($man_page)
= $DB::cmd =~ /\A(?:man|(?:perl)?doc)\b(?:\s+([^(]*))?\z/) {
- runman($man_page);
+ DB::runman($man_page);
next CMD;
}
my $print_cmd = 'print {$DB::OUT} ';
# p - print (no args): print $_.
- if ($DB::cmd eq 'p') {
+ if ($self->_is_full('p')) {
$DB::cmd = $print_cmd . '$_';
}
-
- # p - print the given expression.
- $DB::cmd =~ s/\Ap\b/$print_cmd /;
+ else {
+ # p - print the given expression.
+ $DB::cmd =~ s/\Ap\b/$print_cmd /;
+ }
return;
}
my $self = shift;
# source - read commands from a file (or pipe!) and execute.
- if (my ($sourced_fn) = $DB::cmd =~ /\Asource\s+(.*\S)/) {
+ if (my $sourced_fn = $self->cmd_args) {
if ( open my $fh, $sourced_fn ) {
# Opened OK; stick it in the list of file handles.
else {
# Couldn't open it.
- DB::warn("Can't execute '$sourced_fn': $!\n");
+ DB::_db_warn("Can't execute '$sourced_fn': $!\n");
}
next CMD;
}
sub _handle_enable_disable_commands {
my $self = shift;
- if (my ($which_cmd, $position)
- = $DB::cmd =~ /\A(enable|disable)\s+(\S+)\s*\z/) {
+ my $which_cmd = $self->cmd_verb;
+ my $position = $self->cmd_args;
+ if ($position !~ /\s/) {
my ($fn, $line_num);
if ($position =~ m{\A\d+\z})
{
}
else
{
- DB::warn("Wrong spec for enable/disable argument.\n");
+ DB::_db_warn("Wrong spec for enable/disable argument.\n");
}
if (defined($fn)) {
);
}
else {
- DB::warn("No breakpoint set at ${fn}:${line_num}\n");
+ DB::_db_warn("No breakpoint set at ${fn}:${line_num}\n");
}
}
sub _handle_save_command {
my $self = shift;
- if (my ($new_fn) = $DB::cmd =~ /\Asave\s*(.*)\z/) {
+ if (my $new_fn = $self->cmd_args) {
my $filename = $new_fn || '.perl5dbrc'; # default?
if ( open my $fh, '>', $filename ) {
print "commands saved in $filename\n";
}
else {
- DB::warn("Can't save debugger commands in '$new_fn': $!\n");
+ DB::_db_warn("Can't save debugger commands in '$new_fn': $!\n");
}
next CMD;
}
if ($my_cmd =~ m#\G\z#cgms) {
# Run the user's shell. If none defined, run Bourne.
# We resume execution when the shell terminates.
- DB::system( $ENV{SHELL} || "/bin/sh" );
+ DB::_db_system( $ENV{SHELL} || "/bin/sh" );
next CMD;
}
elsif ($my_cmd =~ m#\G$sh\s*(.*)#cgms) {
# System it.
- DB::system($1);
+ DB::_db_system($1);
next CMD;
}
elsif ($my_cmd =~ m#\G\s*(.*)#cgms) {
- DB::system( $ENV{SHELL} || "/bin/sh", "-c", $1 );
+ DB::_db_system( $ENV{SHELL} || "/bin/sh", "-c", $1 );
next CMD;
}
}
return;
}
+sub _handle_q_command {
+ my $self = shift;
+
+ if ($self->_is_full('q')) {
+ $fall_off_end = 1;
+ DB::clean_ENV();
+ exit $?;
+ }
+
+ return;
+}
+
+sub _handle_cmd_wrapper_commands {
+ my $self = shift;
+
+ DB::cmd_wrapper( $self->cmd_verb, $self->cmd_args, $line );
+ next CMD;
+}
+
+sub _handle_special_char_cmd_wrapper_commands {
+ my $self = shift;
+
+ # All of these commands were remapped in perl 5.8.0;
+ # we send them off to the secondary dispatcher (see below).
+ if (my ($cmd_letter, $my_arg) = $DB::cmd =~ /\A([<>\{]{1,2})\s*(.*)/so) {
+ DB::cmd_wrapper( $cmd_letter, $my_arg, $line );
+ next CMD;
+ }
+
+ return;
+}
+
+} ## end DB::Obj
+
package DB;
# The following code may be executed now:
# We need to fully qualify the name ("DB::sub") to make "use strict;"
# happy. -- Shlomi Fish
-sub DB::sub {
- # Do not use a regex in this subroutine -> results in corrupted memory
- # See: [perl #66110]
+sub _indent_print_line_info {
+ my ($offset, $str) = @_;
+
+ print_lineinfo( ' ' x ($stack_depth - $offset), $str);
+
+ return;
+}
+
+sub _print_frame_message {
+ my ($al) = @_;
+
+ if ($frame) {
+ if ($frame & 4) { # Extended frame entry message
+ _indent_print_line_info(-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.
+ #
+ # Now it's 0 because we extracted a function.
+ print_trace( $LINEINFO, 0, 1, 1, "$sub$al" );
+ }
+ else {
+ _indent_print_line_info(-1, "entering $sub$al\n" );
+ }
+ }
+
+ return;
+}
+
+sub DB::sub {
# lock ourselves under threads
lock($DBGR);
$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" )
+ _print_frame_message($al);
+ # standard frame entry message
- # standard frame entry message
- )
- if $frame;
+ my $print_exit_msg = sub {
+ # Check for exit trace messages...
+ if ($frame & 2)
+ {
+ if ($frame & 4) # Extended exit message
+ {
+ _indent_print_line_info(0, "out ");
+ print_trace( $LINEINFO, 0, 1, 1, "$sub$al" );
+ }
+ else
+ {
+ _indent_print_line_info(0, "exited $sub$al\n" );
+ }
+ }
+ return;
+ };
# Determine the sub's return type, and capture appropriately.
if (wantarray) {
# 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_exit_msg->();
# Print the return info if we need to.
if ( $doret eq $stack_depth or $frame & 16 ) {
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;
+ if ($frame & 16)
+ {
+ print {$fh} ' ' x $stack_depth;
+ }
# Print the return value.
- print $fh "list context return from $sub:\n";
+ print {$fh} "list context return from $sub:\n";
dumpit( $fh, \@ret );
# And don't print it again.
$single |= $stack[ $stack_depth-- ];
# If we're doing exit messages...
- (
- $frame & 4 # Extended messages
- ? (
- 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;
+ $print_exit_msg->();
# If we are supposed to show the return value... same as before.
if ( $doret eq $stack_depth or $frame & 16 and defined wantarray ) {
$stack[-1] = $single;
# Turn off all flags except single-stepping.
- $single &= 1;
+ # Use local so the single-step value is popped back off the
+ # stack for us.
+ local $single = $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-- ];
+ _print_frame_message($al);
# call the original lvalue sub.
&$sub;
=cut
sub cmd_b_sub {
- my ( $subname, $cond ) = @_;
-
- # Add always-true condition if we have none.
- $cond = 1 unless @_ >= 2;
+ my $subname = shift;
+ my $cond = @_ ? shift : 1;
# If the subname isn't a code reference, qualify it so that
# break_subroutine() will work right.
- unless ( ref $subname eq 'CODE' ) {
+ if ( ref($subname) ne 'CODE' ) {
- # Not Perl4.
- $subname =~ s/\'/::/g;
+ # Not Perl 4.
+ $subname =~ s/'/::/g;
my $s = $subname;
# Put it in this package unless it's already qualified.
- $subname = "${package}::" . $subname
- unless $subname =~ /::/;
+ if ($subname !~ /::/)
+ {
+ $subname = $package . '::' . $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"};
+ my $core_name = "CORE::GLOBAL::$s";
+ if ((!defined(&$subname))
+ and ($s !~ /::/)
+ and (defined &{$core_name}))
+ {
+ $subname = $core_name;
+ }
# 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')
+ if ($subname =~ /\A::/)
+ {
+ $subname = "main" . $subname;
+ }
+ } ## end if ( ref($subname) ne 'CODE' ) {
# Try to set the breakpoint.
if (not eval { break_subroutine( $subname, $cond ); 1 }) {
local $\ = '';
- print $OUT $@ and return;
+ print {$OUT} $@;
+ return;
}
return;
my $line = shift;
foreach my $isa ( split( /\s+/, $line ) ) {
$evalarg = $isa;
- ($isa) = DB::eval();
+ # The &-call is here to ascertain the mutability of @_.
+ ($isa) = &DB::eval;
no strict 'refs';
print join(
', ',
=cut
-sub cmd_l {
- my $current_line = $line;
- my $cmd = shift;
- my $line = shift;
+sub _min {
+ my $min = shift;
+ foreach my $v (@_) {
+ if ($min > $v) {
+ $min = $v;
+ }
+ }
+ return $min;
+}
- # If this is '-something', delete any spaces after the dash.
- $line =~ s/^-\s*$/-/;
+sub _max {
+ my $max = shift;
+ foreach my $v (@_) {
+ if ($max < $v) {
+ $max = $v;
+ }
+ }
+ return $max;
+}
- # If the line is '$something', assume this is a scalar containing a
- # line number.
- if ( $line =~ /^(\$.*)/s ) {
+sub _minify_to_max {
+ my $ref = shift;
- # Set up for DB::eval() - evaluate in *user* context.
- $evalarg = $1;
- # $evalarg = $2;
- my ($s) = DB::eval();
+ $$ref = _min($$ref, $max);
- # Ooops. Bad scalar.
- if ($@) {
- print {$OUT} "Error: $@\n";
- next CMD;
- }
+ return;
+}
- # 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";
+sub _cmd_l_handle_var_name {
+ my $var_name = shift;
- # Call self recursively to really do the command.
- cmd_l( 'l', $s );
- } ## end if ($line =~ /^(\$.*)/s)
+ $evalarg = $var_name;
- # l name. Try to find a sub by that name.
- elsif ( ($subname) = $line =~ /\A([\':A-Za-z_][\':\w]*(?:\[.*\])?)/s ) {
- my $s = $subname;
+ my ($s) = DB::eval();
- # De-Perl4.
- $subname =~ s/\'/::/;
+ # Ooops. Bad scalar.
+ if ($@) {
+ print {$OUT} "Error: $@\n";
+ next CMD;
+ }
- # Put it in this package unless it starts with ::.
- $subname = $package . "::" . $subname unless $subname =~ /::/;
+ # 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";
- # 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"};
+ # Call self recursively to really do the command.
+ return _cmd_l_main( $s );
+}
- # Put leading '::' names into 'main::'.
- $subname = "main" . $subname if substr( $subname, 0, 2 ) eq "::";
+sub _cmd_l_handle_subname {
- # Get name:start-stop from find_sub, and break this up at
- # colons.
- my @pieces = split( /:/, find_sub($subname) || $sub{$subname} );
+ my $s = $subname;
- # Pull off start-stop.
- my $subrange = pop @pieces;
+ # De-Perl4.
+ $subname =~ s/\'/::/;
- # If the name contained colons, the split broke it up.
- # Put it back together.
- $file = join( ':', @pieces );
+ # Put it in this package unless it starts with ::.
+ $subname = $package . "::" . $subname unless $subname =~ /::/;
- # 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;
+ # 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"};
- # Switch debugger's magic structures.
- *dbline = $main::{ '_<' . $file };
- $max = $#dbline;
- $filename = $file;
- } ## end if ($file ne $filename)
+ # Put leading '::' names into 'main::'.
+ $subname = "main" . $subname if substr( $subname, 0, 2 ) eq "::";
- # 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/-.*/+/;
- }
+ # Get name:start-stop from find_sub, and break this up at
+ # colons.
+ my @pieces = split( /:/, find_sub($subname) || $sub{$subname} );
- # Call self recursively to list the range.
- $line = $subrange;
- cmd_l( 'l', $subrange );
- } ## end if ($subrange)
+ # Pull off start-stop.
+ my $subrange = pop @pieces;
- # Couldn't find it.
- else {
- print $OUT "Subroutine $subname not found.\n";
+ # 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 ) {
+ if (! $slave_editor) {
+ print {$OUT} "Switching to file '$file'.\n";
}
- } ## end elsif ($line =~ /^([\':A-Za-z_][\':\w]*(\[.*\])?)/s)
- # Bare 'l' command.
- elsif ( $line !~ /\S/ ) {
+ # 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/-.*/+/;
+ }
- # Compute new range to list.
- $incr = $window - 1;
- $line = $start . '-' . ( $start + $incr );
+ # Call self recursively to list the range.
+ return _cmd_l_main( $subrange );
+ } ## end if ($subrange)
- # Recurse to do it.
- cmd_l( 'l', $line );
+ # Couldn't find it.
+ else {
+ print {$OUT} "Subroutine $subname not found.\n";
+ return;
}
+}
- # l [start]+number_of_lines
- elsif ( my ($new_start, $new_incr) = $line =~ /\A(\d*)\+(\d*)\z/ ) {
+sub _cmd_l_empty {
+ # Compute new range to list.
+ $incr = $window - 1;
+
+ # Recurse to do it.
+ return _cmd_l_main( $start . '-' . ( $start + $incr ) );
+}
- # Don't reset start for 'l +nnn'.
- $start = $new_start if $new_start;
+sub _cmd_l_plus {
+ my ($new_start, $new_incr) = @_;
- # Increment for list. Use window size if not specified.
- # (Allows 'l +' to work.)
- $incr = $new_incr;
- $incr = $window - 1 unless $incr;
+ # Don't reset start for 'l +nnn'.
+ $start = $new_start if $new_start;
- # 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*)$/)
+ # Increment for list. Use window size if not specified.
+ # (Allows 'l +' to work.)
+ $incr = $new_incr || ($window - 1);
- # l start-stop or l start,stop
- elsif ( $line =~ /^((-?[\d\$\.]+)([-,]([\d\$\.]+))?)?/ ) {
+ # Create a line range we'll understand, and recurse to do it.
+ return _cmd_l_main( $start . '-' . ( $start + $incr ) );
+}
+
+sub _cmd_l_calc_initial_end_and_i {
+ my ($spec, $start_match, $end_match) = @_;
+
+ # Determine end point; use end of file if not specified.
+ my $end = ( !defined $start_match ) ? $max :
+ ( $end_match ? $end_match : $start_match );
+
+ # Go on to the end, and then stop.
+ _minify_to_max(\$end);
- # Determine end point; use end of file if not specified.
- my $end = ( !defined $2 ) ? $max : ( $4 ? $4 : $2 );
+ # Determine start line.
+ my $i = $start_match;
- # Go on to the end, and then stop.
- $end = $max if $end > $max;
+ if ($i eq '.') {
+ $i = $spec;
+ }
+
+ $i = _max($i, 1);
- # Determine start line.
- my $i = $2;
- $i = $line if $i eq '.';
- $i = 1 if $i < 1;
- $incr = $end - $i;
+ $incr = $end - $i;
+
+ return ($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;
+sub _cmd_l_range {
+ my ($spec, $current_line, $start_match, $end_match) = @_;
+
+ my ($end, $i) =
+ _cmd_l_calc_initial_end_and_i($spec, $start_match, $end_match);
+
+ # 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 {
+ I_TO_END:
+ for ( ; $i <= $end ; $i++ ) {
+
+ # Check for breakpoints and actions.
+ my ( $stop, $action );
+ if ($dbline{$i}) {
+ ( $stop, $action ) = split( /\0/, $dbline{$i} );
+ }
+
+ # ==> if this is the current line in execution,
+ # : if it's breakable.
+ my $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.
+ if ($signal) {
+ $i++;
+ last I_TO_END;
+ }
+ } ## end for (; $i <= $end ; $i++)
+
+ # Line the prompt up; print a newline if the last line listed
+ # didn't have a newline.
+ if ($dbline[ $i - 1 ] !~ /\n\z/) {
+ print {$OUT} "\n";
}
+ } ## end else [ if ($slave_editor)
- # 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++ ) {
+ # 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;
+ _minify_to_max(\$start);
+
+ return;
+}
- # Check for breakpoints and actions.
- my ( $stop, $action );
- ( $stop, $action ) = split( /\0/, $dbline{$i} )
- if $dbline{$i};
+sub _cmd_l_main {
+ my $spec = shift;
- # ==> if this is the current line in execution,
- # : if it's breakable.
- my $arrow =
- ( $i == $current_line and $filename eq $filename_ini )
- ? '==>'
- : ( $dbline[$i] + 0 ? ':' : ' ' );
+ # If this is '-something', delete any spaces after the dash.
+ $spec =~ s/\A-\s*\z/-/;
- # Add break and action indicators.
- $arrow .= 'b' if $stop;
- $arrow .= 'a' if $action;
+ # If the line is '$something', assume this is a scalar containing a
+ # line number.
+ # Set up for DB::eval() - evaluate in *user* context.
+ if ( my ($var_name) = $spec =~ /\A(\$.*)/s ) {
+ return _cmd_l_handle_var_name($var_name);
+ }
+ # l name. Try to find a sub by that name.
+ elsif ( ($subname) = $spec =~ /\A([\':A-Za-z_][\':\w]*(?:\[.*\])?)/s ) {
+ return _cmd_l_handle_subname();
+ }
+ # Bare 'l' command.
+ elsif ( $spec !~ /\S/ ) {
+ return _cmd_l_empty();
+ }
+ # l [start]+number_of_lines
+ elsif ( my ($new_start, $new_incr) = $spec =~ /\A(\d*)\+(\d*)\z/ ) {
+ return _cmd_l_plus($new_start, $new_incr);
+ }
+ # l start-stop or l start,stop
+ elsif (my ($s, $e) = $spec =~ /^(?:(-?[\d\$\.]+)(?:[-,]([\d\$\.]+))?)?/ ) {
+ return _cmd_l_range($spec, $line, $s, $e);
+ }
- # 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\$\.]+))?)?/)
+ return;
} ## end sub cmd_l
+sub cmd_l {
+ my (undef, $line) = @_;
+
+ return _cmd_l_main($line);
+}
+
=head3 C<cmd_L> - list breakpoints, actions, and watch expressions (command)
To list breakpoints, the command has to look determine where all of them are
=cut
-sub cmd_L {
- my $cmd = shift;
-
+sub _cmd_L_calc_arg {
# If no argument, list everything. Pre-5.8.0 version always lists
# everything
my $arg = shift || 'abw';
- $arg = 'abw' unless $CommandSet eq '580'; # sigh...
+ if ($CommandSet ne '580')
+ {
+ $arg = 'abw';
+ }
- # 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;
+ return $arg;
+}
- # Breaks and actions are found together, so we look in the same place
- # for both.
- if ( $break_wanted or $action_wanted ) {
+sub _cmd_L_calc_wanted_flags {
+ my $arg = _cmd_L_calc_arg(shift);
- # Look in all the files with breakpoints...
- for my $file ( keys %had_breakpoints ) {
+ return (map { index($arg, $_) >= 0 ? 1 : 0 } qw(a b w));
+}
- # Temporary switch to this file.
- local *dbline = $main::{ '_<' . $file };
- # Set up to look through the whole file.
- $max = $#dbline;
- my $was; # Flag: did we print something
- # in this file?
+sub _cmd_L_handle_breakpoints {
+ my ($handle_db_line) = @_;
- # For each line in the file ...
- for my $i (1 .. $max) {
+ BREAKPOINTS_SCAN:
+ # Look in all the files with breakpoints...
+ for my $file ( keys %had_breakpoints ) {
- # We've got something on this line.
- if ( defined $dbline{$i} ) {
+ # Temporary switch to this file.
+ local *dbline = $main::{ '_<' . $file };
+
+ # Set up to look through the whole file.
+ $max = $#dbline;
+ my $was; # Flag: did we print something
+ # in this file?
+
+ # For each line in the file ...
+ for my $i (1 .. $max) {
- # Print the header if we haven't.
- print $OUT "$file:\n" unless $was++;
+ # We've got something on this line.
+ if ( defined $dbline{$i} ) {
- # Print the line.
- print $OUT " $i:\t", $dbline[$i];
+ # Print the header if we haven't.
+ if (not $was++) {
+ print {$OUT} "$file:\n";
+ }
- # Pull out the condition and the action.
- my ( $stop, $action ) = split( /\0/, $dbline{$i} );
+ # Print the line.
+ print {$OUT} " $i:\t", $dbline[$i];
- # Print the break if there is one and it's wanted.
- print $OUT " break if (", $stop, ")\n"
- if $stop
- and $break_wanted;
+ $handle_db_line->($dbline{$i});
- # 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.
+ if ($signal) {
+ last BREAKPOINTS_SCAN;
+ }
+ } ## end if (defined $dbline{$i...
+ } ## end for my $i (1 .. $max)
+ } ## end for my $file (keys %had_breakpoints)
- # Quit if the user hit interrupt.
- last if $signal;
- } ## end if (defined $dbline{$i...
- } ## end for my $i (1 .. $max)
- } ## end for my $file (keys %had_breakpoints)
- } ## end if ($break_wanted or $action_wanted)
+ return;
+}
+
+sub _cmd_L_handle_postponed_breakpoints {
+ my ($handle_db_line) = @_;
+
+ print {$OUT} "Postponed breakpoints in files:\n";
+
+ POSTPONED_SCANS:
+ for my $file ( keys %postponed_file ) {
+ my $db = $postponed_file{$file};
+ print {$OUT} " $file:\n";
+ for my $line ( sort { $a <=> $b } keys %$db ) {
+ print {$OUT} " $line:\n";
+
+ $handle_db_line->($db->{$line});
+
+ if ($signal) {
+ last POSTPONED_SCANS;
+ }
+ }
+ if ($signal) {
+ last POSTPONED_SCANS;
+ }
+ }
+
+ return;
+}
+
+
+sub cmd_L {
+ my $cmd = shift;
+
+ my ($action_wanted, $break_wanted, $watch_wanted) =
+ _cmd_L_calc_wanted_flags(shift);
+
+ my $handle_db_line = sub {
+ my ($l) = @_;
+
+ my ( $stop, $action ) = split( /\0/, $l );
+
+ if ($stop and $break_wanted) {
+ print {$OUT} " break if (", $stop, ")\n"
+ }
+
+ if ($action && $action_wanted) {
+ print {$OUT} " action: ", $action, "\n"
+ }
+
+ return;
+ };
+
+ # Breaks and actions are found together, so we look in the same place
+ # for both.
+ if ( $break_wanted or $action_wanted ) {
+ _cmd_L_handle_breakpoints($handle_db_line);
+ }
# Look for breaks in not-yet-compiled subs:
if ( %postponed and $break_wanted ) {
- print $OUT "Postponed breakpoints in subroutines:\n";
+ print {$OUT} "Postponed breakpoints in subroutines:\n";
my $subname;
+ SUBS_SCAN:
for $subname ( keys %postponed ) {
- print $OUT " $subname\t$postponed{$subname}\n";
- last if $signal;
+ print {$OUT} " $subname\t$postponed{$subname}\n";
+ if ($signal) {
+ last SUBS_SCAN;
+ }
}
} ## end if (%postponed and $break_wanted)
# If there are any, list them.
if ( @have and ( $break_wanted or $action_wanted ) ) {
- print $OUT "Postponed breakpoints in files:\n";
- for my $file ( keys %postponed_file ) {
- my $db = $postponed_file{$file};
- print $OUT " $file:\n";
- for my $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)
+ _cmd_L_handle_postponed_breakpoints($handle_db_line);
} ## end if (@have and ($break_wanted...
+
if ( %break_on_load and $break_wanted ) {
print {$OUT} "Breakpoints on load:\n";
BREAK_ON_LOAD: for my $filename ( keys %break_on_load ) {
last BREAK_ON_LOAD if $signal;
}
} ## end if (%break_on_load and...
+
if ($watch_wanted and ( $trace & 2 )) {
print {$OUT} "Watch-expressions:\n" if @to_watch;
TO_WATCH: for my $expr (@to_watch) {
last TO_WATCH if $signal;
}
}
+
+ return;
} ## end sub cmd_L
=head3 C<cmd_M> - list modules (command)
# Nonblank. Try to parse and process.
if ( $opt =~ /^(\S.*)/ ) {
- &parse_options($1);
+ parse_options($1);
}
# Blank. List the current option settings.
else {
for (@options) {
- &dump_option($_);
+ dump_option($_);
}
}
} ## end sub cmd_o
# in the user's context. This version can handle expressions which
# return a list value.
$evalarg = $expr;
- my ($val) = join( ' ', DB::eval() );
+ # The &-call is here to ascertain the mutability of @_.
+ my ($val) = join( ' ', &DB::eval);
$val = ( defined $val ) ? "'$val'" : 'undef';
# Save the current value of the expression.
} ## end foreach (@to_watch)
# We don't bother to turn watching off because
- # a) we don't want to stop calling watchfunction() it it exists
+ # a) we don't want to stop calling watchfunction() if it exists
# b) foreach over a null list doesn't do anything anyway
} ## end elsif ($expr =~ /^(\S.*)/)
resetterm(1) if $LINEINFO eq $OUT and $term_pid != $$;
local $\ = '';
local $, = '';
- print $LINEINFO @_;
+ # $LINEINFO may be undef if $noTTY is set or some other issue.
+ if ($LINEINFO)
+ {
+ print {$LINEINFO} @_;
+ }
} ## end sub print_lineinfo
=head2 C<postponed_sub>
}
# If this is a subroutine, let postponed_sub() deal with it.
- return &postponed_sub unless ref \$_[0] eq 'GLOB';
+ if (ref(\$_[0]) ne 'GLOB') {
+ return postponed_sub(@_);
+ }
# Not a subroutine. Deal with the file.
local *dbline = shift;
my $v = shift;
my $maxdepth = shift || $option{dumpDepth};
$maxdepth = -1 unless defined $maxdepth; # -1 means infinite depth
- &main::dumpValue( $v, $maxdepth );
+ main::dumpValue( $v, $maxdepth );
} ## end if (defined &main::dumpValue)
# Oops, couldn't load dumpvar.pl.
# Drop out if the user has lost interest and hit control-C.
last if $signal;
- # Set the separator so arrys print nice.
+ # Set the separator so arrays print nice.
local $" = ', ';
# Grab and stringify the arguments if they are there.
=cut
+sub _dump_trace_calc_saved_single_arg
+{
+ my ($nothard, $arg) = @_;
+
+ my $type;
+ if ( not defined $arg ) { # undefined parameter
+ return "undef";
+ }
+
+ elsif ( $nothard and tied $arg ) { # tied parameter
+ return "tied";
+ }
+ elsif ( $nothard and $type = ref $arg ) { # reference
+ return "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;
+
+ return $_;
+ }
+}
+
+sub _dump_trace_calc_save_args {
+ my ($nothard) = @_;
+
+ return [
+ map { _dump_trace_calc_saved_single_arg($nothard, $_) } @args
+ ];
+}
+
sub dump_trace {
# How many levels to skip.
# These variables are used to capture output from caller();
my ( $p, $file, $line, $sub, $h, $context );
- my ( $e, $r, @a, @sub, $args );
+ my ( $e, $r, @sub, $args );
# XXX Okay... why'd we do that?
my $nothard = not $frame & 8;
{
# Go through the arguments and save them for later.
- @a = ();
- for my $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)
+ my $save_args = _dump_trace_calc_save_args($nothard);
# If context is true, this is array (@)context.
# If context is false, this is scalar ($) context.
# if the sub has args ($h true), make an anonymous array of the
# dumped args.
- $args = $h ? [@a] : undef;
+ $args = $h ? $save_args : undef;
# remove trailing newline-whitespace-semicolon-end of line sequence
# from the eval text, if any.
while ( $action =~ s/\\$// ) {
# We have a backslash on the end. Read more.
- $action .= &gets;
+ $action .= gets();
} ## end while ($action =~ s/\\$//)
# Return the assembled action.
=cut
sub gets {
- &readline("cont: ");
+ return DB::readline("cont: ");
}
-=head2 C<DB::system()> - handle calls to<system()> without messing up the debugger
+=head2 C<_db_system()> - handle calls to<system()> without messing up the debugger
The C<system()> function assumes that it can just go ahead and use STDIN and
STDOUT, but under the debugger, we want it to use the debugger's input and
outout filehandles.
-C<DB::system()> socks away the program's STDIN and STDOUT, and then substitutes
+C<_db_system()> socks away the program's STDIN and STDOUT, and then substitutes
the debugger's IN and OUT filehandles for them. It does the C<system()> call,
and then puts everything back again.
=cut
-sub system {
+sub _db_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" ) || DB::warn("Can't save STDIN");
- open( SAVEOUT, ">&STDOUT" ) || DB::warn("Can't save STDOUT");
- open( STDIN, "<&IN" ) || DB::warn("Can't redirect STDIN");
- open( STDOUT, ">&OUT" ) || DB::warn("Can't redirect STDOUT");
+ open( SAVEIN, "<&STDIN" ) || _db_warn("Can't save STDIN");
+ open( SAVEOUT, ">&STDOUT" ) || _db_warn("Can't save STDOUT");
+ open( STDIN, "<&IN" ) || _db_warn("Can't redirect STDIN");
+ open( STDOUT, ">&OUT" ) || _db_warn("Can't redirect STDOUT");
# XXX: using csh or tcsh destroys sigint retvals!
system(@_);
- open( STDIN, "<&SAVEIN" ) || DB::warn("Can't restore STDIN");
- open( STDOUT, ">&SAVEOUT" ) || DB::warn("Can't restore STDOUT");
+ open( STDIN, "<&SAVEIN" ) || _db_warn("Can't restore STDIN");
+ open( STDOUT, ">&SAVEOUT" ) || _db_warn("Can't restore STDOUT");
close(SAVEIN);
close(SAVEOUT);
# most of the $? crud was coping with broken cshisms
if ( $? >> 8 ) {
- DB::warn( "(Command exited ", ( $? >> 8 ), ")\n" );
+ _db_warn( "(Command exited ", ( $? >> 8 ), ")\n" );
}
elsif ($?) {
- DB::warn(
+ _db_warn(
"(Command died of SIG#",
( $? & 127 ),
( ( $? & 128 ) ? " -- core dumped" : "" ),
} ## end sub system
+*system = \&_db_system;
+
=head1 TTY MANAGEMENT
The subs here do some of the terminal management for multiple debuggers.
open( OUT, ">$o" ) or die "Cannot open TTY '$o' for write: $!";
$IN = \*IN;
$OUT = \*OUT;
- $OUT->autoflush(1);
+ _autoflush($OUT);
} ## end if ($tty)
# We don't have a TTY - try to find one via Term::Rendezvous.
$term->MinLine(2);
- &load_hist();
+ load_hist();
if ( $term->Features->{setHistory} and "@hist" ne "?" ) {
$term->SetHistory(@hist);
return $tty;
}
+=head3 C<tmux_get_fork_TTY>
+
+Creates a split window for subprocesses when a process running under the
+perl debugger in Tmux forks.
+
+=cut
+
+sub tmux_get_fork_TTY {
+ return unless $ENV{TMUX};
+
+ my $pipe;
+
+ my $status = open $pipe, '-|', 'tmux', 'split-window',
+ '-P', '-F', '#{pane_tty}', 'sleep 100000';
+
+ if ( !$status ) {
+ return;
+ }
+
+ my $tty = <$pipe>;
+ close $pipe;
+
+ if ( $tty ) {
+ chomp $tty;
+
+ if ( !defined $term ) {
+ require Term::ReadLine;
+ if ( !$rl ) {
+ $term = Term::ReadLine::Stub->new( 'perldb', $IN, $OUT );
+ }
+ else {
+ $term = Term::ReadLine->new( 'perldb', $IN, $OUT );
+ }
+ }
+ }
+
+ return $tty;
+}
+
=head2 C<create_IN_OUT($flags)>
Create a new pair of filehandles, pointing to a new TTY. If impossible,
# 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;
+ my $in = get_fork_TTY(@_) if defined &get_fork_TTY;
# It used to be that
$in = $fork_TTY if defined $fork_TTY; # Backward compatibility
=cut
-sub warn {
+sub _db_warn {
my ($msg) = join( "", @_ );
$msg .= ": $!\n" unless $msg =~ /\n$/;
local $\ = '';
print $OUT $msg;
} ## end sub warn
+*warn = \&_db_warn;
+
=head1 INITIALIZATION TTY SUPPORT
=head2 C<reset_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");
+ _db_warn("Too late to set IN/OUT filehandles, enabled on next 'R'!\n");
}
# Set the filehndles up as they were.
}
# Unbuffer the output filehandle.
- $OUT->autoflush(1);
+ _autoflush($OUT);
# Point LINEINFO to the same output filehandle if it was there before.
$LINEINFO = $OUT if $switch_li;
# 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 @_;
+ if ($term and @_) {
+ _db_warn("Too late to set TTY, enabled on next 'R'!\n");
+ }
# Useful if done through PERLDB_OPTS:
$console = $tty = shift if @_;
sub noTTY {
if ($term) {
- &warn("Too late to set noTTY, enabled on next 'R'!\n") if @_;
+ _db_warn("Too late to set noTTY, enabled on next 'R'!\n") if @_;
}
$notty = shift if @_;
$notty;
sub ReadLine {
if ($term) {
- &warn("Too late to set ReadLine, enabled on next 'R'!\n") if @_;
+ _db_warn("Too late to set ReadLine, enabled on next 'R'!\n") if @_;
}
$rl = shift if @_;
$rl;
sub RemotePort {
if ($term) {
- &warn("Too late to set RemotePort, enabled on next 'R'!\n") if @_;
+ _db_warn("Too late to set RemotePort, enabled on next 'R'!\n") if @_;
}
$remoteport = shift if @_;
$remoteport;
sub NonStop {
if ($term) {
- &warn("Too late to set up NonStop mode, enabled on next 'R'!\n")
+ _db_warn("Too late to set up NonStop mode, enabled on next 'R'!\n")
if @_;
}
$runnonstop = shift if @_;
sub DollarCaretP {
if ($term) {
- &warn("Some flag changes could not take effect until next 'R'!\n")
+ _db_warn("Some flag changes could not take effect until next 'R'!\n")
if @_;
}
$^P = parse_DollarCaretP_flags(shift) if @_;
if ( defined $term ) {
# We don't want to show warning backtraces, but we do want die() ones.
- local ( $warnLevel, $dieLevel ) = ( 0, 1 );
+ local $warnLevel = 0;
+ local $dieLevel = 1;
# No ornaments if the terminal doesn't support them.
- return '' unless $term->Features->{ornaments};
- eval { $term->ornaments(@_) } || '';
+ if (not $term->Features->{ornaments}) {
+ return '';
+ }
+
+ return (eval { $term->ornaments(@_) } || '');
}
# Use what was passed in if we can't determine it ourselves.
else {
$ornaments = shift;
+
+ return $ornaments;
}
+
} ## end sub ornaments
=head2 C<recallCommand>
}
# Build it into a printable version.
- $prc = $rc; # Copy it
+ $prc = $rc; # Copy it
$prc =~ s/\\b$//; # Remove trailing \b
$prc =~ s/\\(.)/$1/g; # Remove escapes
- $prc; # Return the printable version
+ return $prc; # Return the printable version
} ## end sub recallCommand
=head2 C<LineInfo> - where the line number information goes
# If this is a pipe, the stream points to a slave editor.
$slave_editor = ( $stream =~ /^\|/ );
+ my $new_lineinfo_fh;
# Open it up and unbuffer it.
- open( LINEINFO, $stream ) || &warn("Cannot open '$stream' for write");
- $LINEINFO = \*LINEINFO;
- $LINEINFO->autoflush(1);
+ open ($new_lineinfo_fh , $stream )
+ or _db_warn("Cannot open '$stream' for write");
+ $LINEINFO = $new_lineinfo_fh;
+ _autoflush($LINEINFO);
}
return $lineinfo;
local $Carp::CarpLevel = 2; # mydie + confess
# Tell us all about it.
- &warn( Carp::longmess("Signal @_") );
+ _db_warn( Carp::longmess("Signal @_") );
}
# No Carp. Tell us about the signal as best we can.
# Use the debugger's own special way of printing warnings to print
# the stack trace message.
- &warn($mess);
+ _db_warn($mess);
} ## end sub dbwarn
=head2 C<dbdie>
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
+ _db_warn(@_); # Yell no matter what
return;
}
if ( $dieLevel < 2 ) {
=head2 C<runman> - run the appropriate command to show documentation
Accepts a man page name; runs the appropriate command to display it (set up
-during debugger initialization). Uses C<DB::system> to avoid mucking up the
+during debugger initialization). Uses C<_db_system()> to avoid mucking up the
program's STDIN and STDOUT.
=cut
-my %_is_in_pods = (map { $_ => 1 }
- qw(
- 5004delta
- 5005delta
- 561delta
- 56delta
- 570delta
- 571delta
- 572delta
- 573delta
- 58delta
- 581delta
- 582delta
- 583delta
- 584delta
- 590delta
- 591delta
- 592delta
- aix
- amiga
- apio
- api
- artistic
- beos
- book
- boot
- bot
- bs2000
- call
- ce
- cheat
- clib
- cn
- compile
- cygwin
- data
- dbmfilter
- debguts
- debtut
- debug
- delta
- dgux
- diag
- doc
- dos
- dsc
- ebcdic
- embed
- epoc
- faq1
- faq2
- faq3
- faq4
- faq5
- faq6
- faq7
- faq8
- faq9
- faq
- filter
- fork
- form
- freebsd
- func
- gpl
- guts
- hack
- hist
- hpux
- hurd
- intern
- intro
- iol
- ipc
- irix
- jp
- ko
- lexwarn
- locale
- lol
- macos
- macosx
- modinstall
- modlib
- mod
- modstyle
- netware
- newmod
- number
- obj
- opentut
- op
- os2
- os390
- os400
- packtut
- plan9
- pod
- podspec
- port
- qnx
- ref
- reftut
- re
- requick
- reref
- retut
- run
- sec
- solaris
- style
- sub
- syn
- thrtut
- tie
- toc
- todo
- tooc
- toot
- trap
- tru64
- tw
- unicode
- uniintro
- util
- uts
- var
- vms
- vos
- win32
- xs
- xstut
- )
-);
-
sub runman {
my $page = shift;
unless ($page) {
- &system("$doccmd $doccmd");
+ _db_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");
+ if ( $doccmd ne 'man' ) {
+ _db_system("$doccmd $page");
return;
}
$page = 'perl' if lc($page) eq 'help';
require Config;
- my $man1dir = $Config::Config{'man1dir'};
- my $man3dir = $Config::Config{'man3dir'};
+ my $man1dir = $Config::Config{man1direxp};
+ my $man3dir = $Config::Config{man3direxp};
for ( $man1dir, $man3dir ) { s#/[^/]*\z## if /\S/ }
my $manpath = '';
$manpath .= "$man1dir:" if $man1dir =~ /\S/;
chop $manpath if $manpath;
# harmless if missing, I figure
- my $oldpath = $ENV{MANPATH};
- $ENV{MANPATH} = $manpath if $manpath;
+ local $ENV{MANPATH} = $manpath if $manpath;
my $nopathopt = $^O =~ /dunno what goes here/;
if (
CORE::system(
)
{
unless ( $page =~ /^perl\w/ ) {
-# do it this way because its easier to slurp in to keep up to date - clunky though.
- if (exists($_is_in_pods{$page})) {
+ # Previously the debugger contained a list which it slurped in,
+ # listing the known "perl" manpages. However, it was out of date,
+ # with errors both of omission and inclusion. This approach is
+ # considerably less complex. The failure mode on a butchered
+ # install is simply that the user has to run man or perldoc
+ # "manually" with the full manpage name.
+
+ # There is a list of $^O values in installperl to determine whether
+ # the directory is 'pods' or 'pod'. However, we can avoid tight
+ # coupling to that by simply checking the "non-standard" 'pods'
+ # first.
+ my $pods = "$Config::Config{privlibexp}/pods";
+ $pods = "$Config::Config{privlibexp}/pod"
+ unless -d $pods;
+ if (-f "$pods/perl$page.pod") {
CORE::system( $doccmd,
( ( $manpath && !$nopathopt ) ? ( "-M", $manpath ) : () ),
"perl$page" );
}
}
} ## 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
# This defines the point at which you get the 'deep recursion'
# warning. It MUST be defined or the debugger will not load.
- $deep = 100;
+ $deep = 1000;
# Number of lines around the current one that are shown in the
# 'w' command.
=cut
push @out, map "$prefix$_", grep /^\Q$text/,
- ( grep /^_?[a-zA-Z]/, keys %$pack ),
+ ( grep /^_?[a-zA-Z]/, do { no strict 'refs'; keys %$pack } ),
( $pack eq '::' ? () : ( grep /::$/, keys %:: ) );
=item *
my @temp = @truehist; # store
push(@DB::typeahead, @truehist); # saved
@truehist = @hist = (); # flush
- @args = &restart(); # setup
- &get_list("PERLDB_HIST"); # clean
- &set_list("PERLDB_HIST", @temp); # reset
+ @args = restart(); # setup
+ get_list("PERLDB_HIST"); # clean
+ set_list("PERLDB_HIST", @temp); # reset
}
return @args;
}
# The breakpoint was inside an eval. This is a little
# more difficult. XXX and I don't understand it.
- for (@hard) {
+ foreach my $hard_file (@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 ];
+ *dbline = $main::{ '_<' . $hard_file };
+ my $quoted = quotemeta $hard_file;
+ my %subs;
+ for my $sub ( keys %sub ) {
+ if (my ($n1, $n2) = $sub{$sub} =~ /\A$quoted:(\d+)-(\d+)\z/) {
+ $subs{$sub} = [ $n1, $n2 ];
+ }
}
unless (%subs) {
- print $OUT
- "No subroutines in $_, ignoring breakpoints.\n";
+ print {$OUT}
+ "No subroutines in $hard_file, ignoring breakpoints.\n";
next;
}
- LINES: for $line ( keys %dbline ) {
+ LINES: foreach my $line ( keys %dbline ) {
# One breakpoint per sub only:
- my ( $offset, $sub, $found );
- SUBS: for $sub ( keys %subs ) {
+ my ( $offset, $found );
+ SUBS: foreach my $sub ( keys %subs ) {
if (
- $subs{$sub}->[1] >=
- $line # Not after the subroutine
+ $subs{$sub}->[1] >= $line # Not after the subroutine
and (
not defined $offset # Not caught
- or $offset < 0
+ or $offset < 0
)
- )
+ )
{ # or badly caught
$found = $sub;
$offset = $line - $subs{$sub}->[0];
- $offset = "+$offset", last SUBS
- if $offset >= 0;
+ if ($offset >= 0) {
+ $offset = "+$offset";
+ last SUBS;
+ }
} ## end if ($subs{$sub}->[1] >=...
} ## end for $sub (keys %subs)
if ( defined $offset ) {
$postponed{$found} =
- "break $offset if $dbline{$line}";
+ "break $offset if $dbline{$line}";
}
else {
- print $OUT
-"Breakpoint in $_:$line ignored: after all the subroutines.\n";
+ print {$OUT}
+ ("Breakpoint in ${hard_file}:$line ignored:"
+ . " after all the subroutines.\n");
}
} ## end for $line (keys %dbline)
} ## end for (@hard)
# Do not stop in at_exit() and destructors on exit:
if ($fall_off_end or $runnonstop) {
- &save_hist();
+ save_hist();
} else {
$DB::single = 1;
DB::fake::at_exit();
if ( $cmd =~ /^load\b\s*(.*)/ ) {
my $file = $1;
$file =~ s/\s+$//;
- &cmd_b_load($file);
+ cmd_b_load($file);
}
# b compile|postpone <some sub> [<condition>]
elsif ( $cmd =~ /^([':A-Za-z_][':\w]*(?:\[.*\])?)\s*(.*)/ ) {
my $subname = $1;
my $cond = length $2 ? $2 : '1';
- &cmd_b_sub( $subname, $cond );
+ cmd_b_sub( $subname, $cond );
}
# b <line> [<condition>].
elsif ( $cmd =~ /^(\d*)\s*(.*)/ ) {
my $i = $1 || $dbline;
my $cond = length $2 ? $2 : '1';
- &cmd_b_line( $i, $cond );
+ cmd_b_line( $i, $cond );
}
} ## end sub cmd_pre580_b
# Get the current value of the expression.
# Doesn't handle expressions returning list values!
$evalarg = $1;
- my ($val) = DB::eval();
+ # The &-call is here to ascertain the mutability of @_.
+ my ($val) = &DB::eval;
$val = ( defined $val ) ? "'$val'" : 'undef';
# Save it.
my $line = shift || '*';
my $dbline = shift;
- return &cmd_prepost( $cmd, $line, $dbline );
+ return cmd_prepost( $cmd, $line, $dbline );
} ## end sub cmd_pre590_prepost
=head2 C<cmd_prepost>
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
+ # This means that if for some reason the tests fail, we won't be
# trying to stash actions or delete them from the wrong place.
my $aref = [];
https://perl5.git.perl.org / perl5.git / blobdiff