structure and services provided by C<perl5db.pl>, and to describe how you
can use them.
+See L<perldebug> for an overview of how to use the debugger.
+
=head1 GENERAL NOTES
The debugger can look pretty forbidding to many Perl programmers. There are
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).
+like C<(eval 34)>.
=head1 DEBUGGER STARTUP
=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_06';
+# bump to X.XX in blead, only use X.XX_XX in maint
+$VERSION = '1.59';
$header = "perl5db.pl version $VERSION";
$filename
$histfile
$histsize
+ $histitemminlength
$IN
$inhibit_exit
@ini_INC
# 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) {
lock($DBGR);
print "Threads support enabled\n";
} else {
+ *lock = sub(*) {};
*share = sub(\[$@%]) {};
}
}
@options = qw(
CommandSet HistFile HistSize
+ HistItemMinLength
hashDepth arrayDepth dumpDepth
DumpDBFiles DumpPackages DumpReused
compactDump veryCompact quote
windowSize => \$window,
HistFile => \$histfile,
HistSize => \$histsize,
+ HistItemMinLength => \$histitemminlength
);
=pod
share($pre);
share($post);
share($pretype);
-share($rl);
share($CreateTTY);
share($CommandSet);
{
*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 * Windows or MSDOS - use C<con>.
=cut
- elsif ( -e "/dev/tty" ) {
- $console = "/dev/tty";
+ elsif ( $^O eq 'dos' or -e "con" or $^O eq 'MSWin32' ) {
+ $console = "con";
}
-=item * Windows or MSDOS - use C<con>.
+=item * AmigaOS - use C<CONSOLE:>.
=cut
- elsif ( $^O eq 'dos' or -e "con" or $^O eq 'MSWin32' ) {
- $console = "con";
+ elsif ( $^O eq 'amigaos' ) {
+ $console = "CONSOLE:";
}
=item * VMS - use C<sys$command>.
=cut
- else {
+ elsif ($^O eq 'VMS') {
+ $console = 'sys$command';
+ }
+
+# Keep this penultimate, on the grounds that it satisfies a wide variety of
+# Unix-like systems that would otherwise need to be identified individually.
+
+=item * Unix - use F</dev/tty>.
+
+=cut
+
+ elsif ( -e "/dev/tty" ) {
+ $console = "/dev/tty";
+ }
+
+# Keep this last.
- # everything else is ...
- $console = "sys\$command";
+ else {
+ _db_warn("Can't figure out your console, using stdin");
+ undef $console;
}
=pod
$o = $i unless defined $o;
# read/write on in, or just read, or read on STDIN.
- open( IN, "+<$i" )
- || open( IN, "<$i" )
+ open( IN, '+<', $i )
+ || open( IN, '<', $i )
|| open( IN, "<&STDIN" );
# read/write/create/clobber out, or write/create/clobber out,
# or merge with STDERR, or merge with STDOUT.
- open( OUT, "+>$o" )
- || open( OUT, ">$o" )
+ open( OUT, '+>', $o )
+ || open( OUT, '>', $o )
|| open( OUT, ">&STDERR" )
|| open( OUT, ">&STDOUT" ); # so we don't dongle stdout
} ## 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
# 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);
}
$cmd =~ s/\A\s+//s; # trim annoying leading whitespace
$cmd =~ s/\s+\z//s; # trim annoying trailing whitespace
- my ($verb, $args) = $cmd =~ m{\A(\S*)\s*(.*)}s;
+ # A single-character debugger command can be immediately followed by its
+ # argument if they aren't both alphanumeric; otherwise require space
+ # between commands and arguments:
+ my ($verb, $args) = $cmd =~ m{\A([^\.-]\b|\S*)\s*(.*)}s;
$obj->cmd_verb($verb);
$obj->cmd_args($args);
= $obj->cmd_args =~ /\A(?:(\d*)\s*(.*))?\z/) {
# See if we've got the necessary support.
- if (!eval { require PadWalker; PadWalker->VERSION(0.08) }) {
+ if (!eval {
+ local @INC = @INC;
+ pop @INC if $INC[-1] eq '.';
+ require PadWalker; PadWalker->VERSION(0.08) }) {
my $Err = $@;
_db_warn(
$Err =~ /locate/
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 = $@) {
# 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__};
# R - restart execution.
# rerun - controlled restart execution.
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
+ # 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
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.
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;
}
-# '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 P v w W)),
-);
+sub _DB__handle_watch_expressions
+{
+ my $self = shift;
-sub DB {
+ 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
- # lock the debugger and get the thread id for the prompt
- lock($DBGR);
- my $tid;
- my $position;
- my ($prefix, $after, $infix);
- my $pat;
- my $explicit_stop;
- my $piped;
- my $selected;
+ # 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' );
- if ($ENV{PERL5DB_THREADED}) {
- $tid = eval { "[".threads->tid."]" };
- }
+ # Did it change?
+ if ( $val ne $DB::old_watch[$n] ) {
- my $cmd_verb;
- my $cmd_args;
+ # 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)
- my $obj = DB::Obj->new(
- {
- position => \$position,
- prefix => \$prefix,
- after => \$after,
- explicit_stop => \$explicit_stop,
- infix => \$infix,
- cmd_args => \$cmd_args,
- cmd_verb => \$cmd_verb,
- pat => \$pat,
- piped => \$piped,
- selected => \$selected,
- },
- );
+ return;
+}
- $obj->_DB_on_init__initialize_globals(@_);
+=head3 C<_DB__handle_i_command> - inheritance display
- # Preserve current values of $@, $!, $^E, $,, $/, $\, $^W.
- # The code being debugged may have altered them.
- DB::save();
+Display the (nested) parentage of the module or object given.
- # Since DB::DB gets called after every line, we can use caller() to
- # figure out where we last were executing. Sneaky, eh? This works because
- # caller is returning all the extra information when called from the
- # debugger.
- local ( $package, $filename, $line ) = caller;
- $filename_ini = $filename;
+=cut
- # set up the context for DB::eval, so it can properly execute
- # code on behalf of the user. We add the package in so that the
- # code is eval'ed in the proper package (not in the debugger!).
- local $usercontext = _calc_usercontext($package);
+sub _DB__handle_i_command {
+ my $self = shift;
- # Create an alias to the active file magical array to simplify
- # the code here.
- local (*dbline) = $main::{ '_<' . $filename };
+ my $line = $self->cmd_args;
+ require mro;
+ foreach my $isa ( split( /\s+/, $line ) ) {
+ $evalarg = "$isa";
+ # The &-call is here to ascertain the mutability of @_.
+ ($isa) = &DB::eval;
+ no strict 'refs';
+ print join(
+ ', ',
+ map {
+ "$_"
+ . (
+ defined( ${"$_\::VERSION"} )
+ ? ' ' . ${"$_\::VERSION"}
+ : undef )
+ } @{mro::get_linear_isa(ref($isa) || $isa)}
+ );
+ print "\n";
+ }
+ next CMD;
+}
- # Last line in the program.
- $max = $#dbline;
+=head3 C<cmd_l> - list lines (command)
- _DB__determine_if_we_should_break(@_);
+Most of the command is taken up with transforming all the different line
+specification syntaxes into 'start-stop'. After that is done, the command
+runs a loop over C<@dbline> for the specified range of lines. It handles
+the printing of each line and any markers (C<==E<gt>> for current line,
+C<b> for break on this line, C<a> for action on this line, C<:> for this
+line breakable).
- # Preserve the current stop-or-not, and see if any of the W
- # (watch expressions) has changed.
- my $was_signal = $signal;
+We save the last line listed in the C<$start> global for further listing
+later.
- # If we have any watch expressions ...
- $obj->_DB__handle_watch_expressions(@_);
+=cut
-=head2 C<watchfunction()>
+sub _min {
+ my $min = shift;
+ foreach my $v (@_) {
+ if ($min > $v) {
+ $min = $v;
+ }
+ }
+ return $min;
+}
-C<watchfunction()> is a function that can be defined by the user; it is a
-function which will be run on each entry to C<DB::DB>; it gets the
-current package, filename, and line as its parameters.
+sub _max {
+ my $max = shift;
+ foreach my $v (@_) {
+ if ($max < $v) {
+ $max = $v;
+ }
+ }
+ return $max;
+}
-The watchfunction can do anything it likes; it is executing in the
-debugger's context, so it has access to all of the debugger's internal
-data structures and functions.
+sub _minify_to_max {
+ my $ref = shift;
-C<watchfunction()> can control the debugger's actions. Any of the following
-will cause the debugger to return control to the user's program after
-C<watchfunction()> executes:
+ $$ref = _min($$ref, $max);
-=over 4
+ return;
+}
-=item *
+sub _cmd_l_handle_var_name {
+ my $var_name = shift;
-Returning a false value from the C<watchfunction()> itself.
+ $evalarg = $var_name;
-=item *
+ my ($s) = DB::eval();
-Altering C<$single> to a false value.
+ # Ooops. Bad scalar.
+ if ($@) {
+ print {$OUT} "Error: $@\n";
+ next CMD;
+ }
-=item *
+ # 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";
-Altering C<$signal> to a false value.
+ # Call self recursively to really do the command.
+ return _cmd_l_main( $s );
+}
-=item *
+sub _cmd_l_handle_subname {
-Turning off the C<4> bit in C<$trace> (this also disables the
-check for C<watchfunction()>. This can be done with
+ my $s = $subname;
- $trace &= ~4;
+ # De-Perl4.
+ $subname =~ s/\'/::/;
-=back
+ # Put it in this package unless it starts with ::.
+ $subname = $package . "::" . $subname unless $subname =~ /::/;
-=cut
+ # 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"};
- # If there's a user-defined DB::watchfunction, call it with the
- # current package, filename, and line. The function executes in
- # the DB:: package.
- if ( $trace & 4 ) { # User-installed watch
- return
- if watchfunction( $package, $filename, $line )
- and not $single
- and not $was_signal
- and not( $trace & ~4 );
- } ## end if ($trace & 4)
+ # Put leading '::' names into 'main::'.
+ $subname = "main" . $subname if substr( $subname, 0, 2 ) eq "::";
- # Pick up any alteration to $signal in the watchfunction, and
- # turn off the signal now.
- $was_signal = $signal;
- $signal = 0;
+ # Get name:start-stop from find_sub, and break this up at
+ # colons.
+ my @pieces = split( /:/, find_sub($subname) || $sub{$subname} );
-=head2 GETTING READY TO EXECUTE COMMANDS
-
-The debugger decides to take control if single-step mode is on, the
-C<t> command was entered, or the user generated a signal. If the program
-has fallen off the end, we set things up so that entering further commands
-won't cause trouble, and we say that the program is over.
-
-=cut
-
- # Make sure that we always print if asked for explicitly regardless
- # of $trace_to_depth .
- $explicit_stop = ($single || $was_signal);
-
- # Check to see if we should grab control ($single true,
- # trace set appropriately, or we got a signal).
- if ( $explicit_stop || ( $trace & 1 ) ) {
- $obj->_DB__grab_control(@_);
- } ## end if ($single || ($trace...
-
-=pod
-
-If there's an action to be executed for the line we stopped at, execute it.
-If there are any preprompt actions, execute those as well.
-
-=cut
-
- # If there's an action, do it now.
- if ($action) {
- $evalarg = $action;
- DB::eval();
- }
-
- # Are we nested another level (e.g., did we evaluate a function
- # that had a breakpoint in it at the debugger prompt)?
- if ( $single || $was_signal ) {
-
- # Yes, go down a level.
- local $level = $level + 1;
+ # Pull off start-stop.
+ my $subrange = pop @pieces;
- # Do any pre-prompt actions.
- foreach $evalarg (@$pre) {
- DB::eval();
- }
+ # If the name contained colons, the split broke it up.
+ # Put it back together.
+ $file = join( ':', @pieces );
- # Complain about too much recursion if we passed the limit.
- if ($single & 4) {
- print $OUT $stack_depth . " levels deep in subroutine calls!\n";
+ # 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";
}
- # The line we're currently on. Set $incr to -1 to stay here
- # until we get a command that tells us to advance.
- $start = $line;
- $incr = -1; # for backward motion.
-
- # Tack preprompt debugger actions ahead of any actual input.
- @typeahead = ( @$pretype, @typeahead );
-
-=head2 WHERE ARE WE?
-
-XXX Relocate this section?
-
-The debugger normally shows the line corresponding to the current line of
-execution. Sometimes, though, we want to see the next line, or to move elsewhere
-in the file. This is done via the C<$incr>, C<$start>, and C<$max> variables.
-
-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 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
-used to terminate loops most often.
-
-=head2 THE COMMAND LOOP
-
-Most of C<DB::DB> is actually a command parsing and dispatch loop. It comes
-in two parts:
-
-=over 4
-
-=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
-is wholly contained inside the C<CMD> block and only executes a command.
-Used to handle commands running inside a pager.
-
-=back
-
-So why have two labels to restart the loop? Because sometimes, it's easier to
-have a command I<generate> another command and then re-execute the loop to do
-the new command. This is faster, but perhaps a bit more convoluted.
-
-=cut
-
- # The big command dispatch loop. It keeps running until the
- # user yields up control again.
- #
- # If we have a terminal for input, and we get something back
- # from readline(), keep on processing.
-
- CMD:
- while (_DB__read_next_cmd($tid))
- {
-
- share($cmd);
- # ... try to execute the input as debugger commands.
-
- # Don't stop running.
- $single = 0;
-
- # No signal is active.
- $signal = 0;
-
- # Handle continued commands (ending with \):
- if ($cmd =~ s/\\\z/\n/) {
- $cmd .= DB::readline(" cont: ");
- redo CMD;
- }
-
-=head4 The null command
-
-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
-in the command history and fall through to allow the command parsing to pick
-it up.
-
-=cut
-
- # Empty input means repeat the last command.
- if ($cmd eq '') {
- $cmd = $laststep;
- }
- chomp($cmd); # get rid of the annoying extra newline
- if (length($cmd) >= 2) {
- push( @hist, $cmd );
- }
- 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
- # re-execute command processing without reading a new command.
- PIPE: {
- _DB__trim_command_and_return_first_component($obj);
-
-=head3 COMMAND ALIASES
-
-The debugger can create aliases for commands (these are stored in the
-C<%alias> hash). Before a command is executed, the command loop looks it up
-in the alias hash and substitutes the contents of the alias for the command,
-completely replacing it.
-
-=cut
-
- # See if there's an alias for the command, and set it up if so.
- if ( $alias{$cmd_verb} ) {
-
- # Squelch signal handling; we want to keep control here
- # if something goes loco during the alias eval.
- local $SIG{__DIE__};
- local $SIG{__WARN__};
-
- # This is a command, so we eval it in the DEBUGGER's
- # scope! Otherwise, we can't see the special debugger
- # variables, or get to the debugger's subs. (Well, we
- # _could_, but why make it even more complicated?)
- eval "\$cmd =~ $alias{$cmd_verb}";
- if ($@) {
- local $\ = '';
- print $OUT "Couldn't evaluate '$cmd_verb' alias: $@";
- next CMD;
- }
- _DB__trim_command_and_return_first_component($obj);
- } ## end if ($alias{$cmd_verb})
-
-=head3 MAIN-LINE COMMANDS
-
-All of these commands work up to and after the program being debugged has
-terminated.
-
-=head4 C<q> - quit
-
-Quit the debugger. This entails setting the C<$fall_off_end> flag, so we don't
-try to execute further, cleaning any restart-related stuff out of the
-environment, and executing with the last value of C<$?>.
-
-=cut
-
- # 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>.
-
-=head4 C<S> - list subroutines matching/not matching a pattern
-
-Walks through C<%sub>, checking to see whether or not to print the name.
-
-=head4 C<X> - list variables in current package
-
-Since the C<V> command actually processes this, just change this to the
-appropriate C<V> command and fall through.
-
-=head4 C<V> - list variables
-
-Uses C<dumpvar.pl> to dump out the current values for selected variables.
-
-=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.
-
-=head4 C<m> - print methods
-
-Just uses C<DB::methods> to determine what methods are available.
-
-=head4 C<f> - switch files
-
-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.
+ # Switch debugger's magic structures.
+ *dbline = $main::{ '_<' . $file };
+ $max = $#dbline;
+ $filename = $file;
+ } ## end if ($file ne $filename)
-=head4 C<-> - back one window
+ # 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/-.*/+/;
+ }
-We change C<$start> to be one window back; if we go back past the first line,
-we set it to be the first line. We ser C<$incr> to put us back at the
-currently-executing line, and then put a C<l $start +> (list one window from
-C<$start>) in C<$cmd> to be executed later.
+ # Call self recursively to list the range.
+ return _cmd_l_main( $subrange );
+ } ## end if ($subrange)
-=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>>
+ # Couldn't find it.
+ else {
+ print {$OUT} "Subroutine $subname not found.\n";
+ return;
+ }
+}
-In Perl 5.8.0, a realignment of the commands was done to fix up a number of
-problems, most notably that the default case of several commands destroying
-the user's work in setting watchpoints, actions, etc. We wanted, however, to
-retain the old commands for those who were used to using them or who preferred
-them. At this point, we check for the new commands and call C<cmd_wrapper> to
-deal with them instead of processing them in-line.
+sub _cmd_l_empty {
+ # Compute new range to list.
+ $incr = $window - 1;
-=head4 C<y> - List lexicals in higher scope
+ # Recurse to do it.
+ return _cmd_l_main( $start . '-' . ( $start + $incr ) );
+}
-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>.
+sub _cmd_l_plus {
+ my ($new_start, $new_incr) = @_;
-=head3 COMMANDS NOT WORKING AFTER PROGRAM ENDS
+ # Don't reset start for 'l +nnn'.
+ $start = $new_start if $new_start;
-All of the commands below this point don't work after the program being
-debugged has ended. All of them check to see if the program has ended; this
-allows the commands to be relocated without worrying about a 'line of
-demarcation' above which commands can be entered anytime, and below which
-they can't.
+ # Increment for list. Use window size if not specified.
+ # (Allows 'l +' to work.)
+ $incr = $new_incr || ($window - 1);
-=head4 C<n> - single step, but don't trace down into subs
+ # Create a line range we'll understand, and recurse to do it.
+ return _cmd_l_main( $start . '-' . ( $start + $incr ) );
+}
-Done by setting C<$single> to 2, which forces subs to execute straight through
-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.
+sub _cmd_l_calc_initial_end_and_i {
+ my ($spec, $start_match, $end_match) = @_;
-=head4 C<s> - single-step, entering subs
+ # Determine end point; use end of file if not specified.
+ my $end = ( !defined $start_match ) ? $max :
+ ( $end_match ? $end_match : $start_match );
-Sets C<$single> to 1, which causes C<DB::sub> to continue tracing inside
-subs. Also saves C<s> as C<$lastcmd>.
+ # Go on to the end, and then stop.
+ _minify_to_max(\$end);
-=head4 C<c> - run continuously, setting an optional breakpoint
+ # Determine start line.
+ my $i = $start_match;
-Most of the code for this command is taken up with locating the optional
-breakpoint, which is either a subroutine name or a line number. We set
-the appropriate one-time-break in C<@dbline> and then turn off single-stepping
-in this and all call levels above this one.
+ if ($i eq '.') {
+ $i = $spec;
+ }
-=head4 C<r> - return from a subroutine
+ $i = _max($i, 1);
-For C<r> to work properly, the debugger has to stop execution again
-immediately after the return is executed. This is done by forcing
-single-stepping to be on in the call level above the current one. If
-we are printing return values when a C<r> is executed, set C<$doret>
-appropriately, and force us out of the command loop.
+ $incr = $end - $i;
-=head4 C<T> - stack trace
+ return ($end, $i);
+}
-Just calls C<DB::print_trace>.
+sub _cmd_l_range {
+ my ($spec, $current_line, $start_match, $end_match) = @_;
-=head4 C<w> - List window around current line.
+ my ($end, $i) =
+ _cmd_l_calc_initial_end_and_i($spec, $start_match, $end_match);
-Just calls C<DB::cmd_w>.
+ # 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++ ) {
-=head4 C<W> - watch-expression processing.
+ # Check for breakpoints and actions.
+ my ( $stop, $action );
+ if ($dbline{$i}) {
+ ( $stop, $action ) = split( /\0/, $dbline{$i} );
+ }
-Just calls C<DB::cmd_W>.
+ # ==> 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 ? ':' : ' ' );
-=head4 C</> - search forward for a string in the source
+ # Add break and action indicators.
+ $arrow .= 'b' if $stop;
+ $arrow .= 'a' if $action;
-We take the argument and treat it as a pattern. If it turns out to be a
-bad one, we return the error we got from trying to C<eval> it and exit.
-If not, we create some code to do the search and C<eval> it so it can't
-mess us up.
+ # Print the line.
+ print {$OUT} "$i$arrow\t", $dbline[$i];
-=cut
+ # Move on to the next line. Drop out on an interrupt.
+ if ($signal) {
+ $i++;
+ last I_TO_END;
+ }
+ } ## end for (; $i <= $end ; $i++)
- _DB__handle_forward_slash_command($obj);
+ # 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)
-=head4 C<?> - search backward for a string in the source
+ # 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);
-Same as for C</>, except the loop runs backwards.
+ return;
+}
-=cut
+sub _cmd_l_main {
+ my $spec = shift;
- _DB__handle_question_mark_command($obj);
+ # If this is '-something', delete any spaces after the dash.
+ $spec =~ s/\A-\s*\z/-/;
-=head4 C<$rc> - Recall command
+ # 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);
+ }
-Manages the commands in C<@hist> (which is created if C<Term::ReadLine> reports
-that the terminal supports history). It find the the command required, puts it
-into C<$cmd>, and redoes the loop to execute it.
+ return;
+} ## end sub cmd_l
-=cut
+sub _DB__handle_l_command {
+ my $self = shift;
- # $rc - recall command.
- $obj->_handle_rc_recall_command;
+ _cmd_l_main($self->cmd_args);
+ next CMD;
+}
-=head4 C<$sh$sh> - C<system()> command
-Calls the C<_db_system()> to handle the command. This keeps the C<STDIN> and
-C<STDOUT> from getting messed up.
+# 't' is type.
+# 'm' is method.
+# 'v' is the value (i.e: method name or subroutine ref).
+# 's' is subroutine.
+my %cmd_lookup;
-=cut
+BEGIN
+{
+ %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, },
+ 'i' => { t => 's', v => \&_DB__handle_i_command, },
+ 'l' => { t => 's', v => \&_DB__handle_l_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 L M o O v w W)),
+);
+};
- $obj->_handle_sh_command;
+sub DB {
-=head4 C<$rc I<pattern> $rc> - Search command history
+ # lock the debugger and get the thread id for the prompt
+ lock($DBGR);
+ my $tid;
+ my $position;
+ my ($prefix, $after, $infix);
+ my $pat;
+ my $explicit_stop;
+ my $piped;
+ my $selected;
-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 C<redo>.
+ if ($ENV{PERL5DB_THREADED}) {
+ $tid = eval { "[".threads->tid."]" };
+ }
-=cut
+ my $cmd_verb;
+ my $cmd_args;
- $obj->_handle_rc_search_history_command;
+ my $obj = DB::Obj->new(
+ {
+ position => \$position,
+ prefix => \$prefix,
+ after => \$after,
+ explicit_stop => \$explicit_stop,
+ infix => \$infix,
+ cmd_args => \$cmd_args,
+ cmd_verb => \$cmd_verb,
+ pat => \$pat,
+ piped => \$piped,
+ selected => \$selected,
+ },
+ );
-=head4 C<$sh> - Invoke a shell
+ $obj->_DB_on_init__initialize_globals(@_);
-Uses C<_db_system()> to invoke a shell.
+ # Preserve current values of $@, $!, $^E, $,, $/, $\, $^W.
+ # The code being debugged may have altered them.
+ DB::save();
-=cut
+ # Since DB::DB gets called after every line, we can use caller() to
+ # figure out where we last were executing. Sneaky, eh? This works because
+ # caller is returning all the extra information when called from the
+ # debugger.
+ local ( $package, $filename, $line ) = caller;
+ $filename_ini = $filename;
-=head4 C<$sh I<command>> - Force execution of a command in a shell
+ # set up the context for DB::eval, so it can properly execute
+ # code on behalf of the user. We add the package in so that the
+ # code is eval'ed in the proper package (not in the debugger!).
+ local $usercontext = _calc_usercontext($package);
-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>.
+ # Create an alias to the active file magical array to simplify
+ # the code here.
+ local (*dbline) = $main::{ '_<' . $filename };
-=head4 C<H> - display commands in history
+ # Last line in the program.
+ $max = $#dbline;
-Prints the contents of C<@hist> (if any).
+ # The &-call is here to ascertain the mutability of @_.
+ &_DB__determine_if_we_should_break;
-=head4 C<man, doc, perldoc> - look up documentation
+ # Preserve the current stop-or-not, and see if any of the W
+ # (watch expressions) has changed.
+ my $was_signal = $signal;
-Just calls C<runman()> to print the appropriate document.
+ # If we have any watch expressions ...
+ _DB__handle_watch_expressions($obj);
-=cut
+=head2 C<watchfunction()>
- $obj->_handle_doc_command;
+C<watchfunction()> is a function that can be defined by the user; it is a
+function which will be run on each entry to C<DB::DB>; it gets the
+current package, filename, and line as its parameters.
-=head4 C<p> - print
+The watchfunction can do anything it likes; it is executing in the
+debugger's context, so it has access to all of the debugger's internal
+data structures and functions.
-Builds a C<print EXPR> expression in the C<$cmd>; this will get executed at
-the bottom of the loop.
+C<watchfunction()> can control the debugger's actions. Any of the following
+will cause the debugger to return control to the user's program after
+C<watchfunction()> executes:
-=head4 C<=> - define command alias
+=over 4
-Manipulates C<%alias> to add or list command aliases.
+=item *
-=head4 C<source> - read commands from a file.
+Returning a false value from the C<watchfunction()> itself.
-Opens a lexical filehandle and stacks it on C<@cmdfhs>; C<DB::readline> will
-pick it up.
+=item *
-=head4 C<enable> C<disable> - enable or disable breakpoints
+Altering C<$single> to a false value.
-This enables or disables breakpoints.
+=item *
-=head4 C<save> - send current history to a file
+Altering C<$signal> to a false value.
-Takes the complete history, (not the shrunken version you see with C<H>),
-and saves it to the given filename, so it can be replayed using C<source>.
+=item *
-Note that all C<^(save|source)>'s are commented out with a view to minimise recursion.
+Turning off the C<4> bit in C<$trace> (this also disables the
+check for C<watchfunction()>. This can be done with
-=head4 C<R> - restart
+ $trace &= ~4;
-Restart the debugger session.
+=back
-=head4 C<rerun> - rerun the current session
+=cut
-Return to any given position in the B<true>-history list
+ # If there's a user-defined DB::watchfunction, call it with the
+ # current package, filename, and line. The function executes in
+ # the DB:: package.
+ if ( $trace & 4 ) { # User-installed watch
+ return
+ if watchfunction( $package, $filename, $line )
+ and not $single
+ and not $was_signal
+ and not( $trace & ~4 );
+ } ## end if ($trace & 4)
-=head4 C<|, ||> - pipe output through the pager.
+ # Pick up any alteration to $signal in the watchfunction, and
+ # turn off the signal now.
+ $was_signal = $signal;
+ $signal = 0;
-For C<|>, we save C<OUT> (the debugger's output filehandle) and C<STDOUT>
-(the program's standard output). For C<||>, we only save C<OUT>. We open a
-pipe to the pager (restoring the output filehandles if this fails). If this
-is the C<|> command, we also set up a C<SIGPIPE> handler which will simply
-set C<$signal>, sending us back into the debugger.
+=head2 GETTING READY TO EXECUTE COMMANDS
-We then trim off the pipe symbols and C<redo> the command loop at the
-C<PIPE> label, causing us to evaluate the command in C<$cmd> without
-reading another.
+The debugger decides to take control if single-step mode is on, the
+C<t> command was entered, or the user generated a signal. If the program
+has fallen off the end, we set things up so that entering further commands
+won't cause trouble, and we say that the program is over.
=cut
- # || - run command in the pager, with output to DB::OUT.
- _DB__handle_run_command_in_pager_command($obj);
+ # Make sure that we always print if asked for explicitly regardless
+ # of $trace_to_depth .
+ $explicit_stop = ($single || $was_signal);
-=head3 END OF COMMAND PARSING
+ # Check to see if we should grab control ($single true,
+ # trace set appropriately, or we got a signal).
+ if ( $explicit_stop || ( $trace & 1 ) ) {
+ $obj->_DB__grab_control(@_);
+ } ## end if ($single || ($trace...
-Anything left in C<$cmd> at this point is a Perl expression that we want to
-evaluate. We'll always evaluate in the user's context, and fully qualify
-any variables we might want to address in the C<DB> package.
+=pod
+
+If there's an action to be executed for the line we stopped at, execute it.
+If there are any preprompt actions, execute those as well.
=cut
- } # PIPE:
+ # If there's an action, do it now.
+ if ($action) {
+ $evalarg = $action;
+ # The &-call is here to ascertain the mutability of @_.
+ &DB::eval;
+ }
+ undef $action;
- # trace an expression
- $cmd =~ s/^t\s/\$DB::trace |= 1;\n/;
+ # Are we nested another level (e.g., did we evaluate a function
+ # that had a breakpoint in it at the debugger prompt)?
+ if ( $single || $was_signal ) {
- # 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";
+ # Yes, go down a level.
+ local $level = $level + 1;
- # Run *our* eval that executes in the caller's context.
- DB::eval();
+ # Do any pre-prompt actions.
+ foreach $evalarg (@$pre) {
+ # The &-call is here to ascertain the mutability of @_.
+ &DB::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();
- };
+ # Complain about too much recursion if we passed the limit.
+ if ($single & 4) {
+ print $OUT $stack_depth . " levels deep in subroutine calls!\n";
+ }
- # XXX If this is the master pid, print a newline.
- print {$OUT} "\n";
- }
- } ## end while (($term || &setterm...
+ # The line we're currently on. Set $incr to -1 to stay here
+ # until we get a command that tells us to advance.
+ $start = $line;
+ $incr = -1; # for backward motion.
-=head3 POST-COMMAND PROCESSING
+ # Tack preprompt debugger actions ahead of any actual input.
+ @typeahead = ( @$pretype, @typeahead );
-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.
+=head2 WHERE ARE WE?
-=cut
+XXX Relocate this section?
- continue { # CMD:
- _DB__at_end_of_every_command($obj);
- } # CMD:
+The debugger normally shows the line corresponding to the current line of
+execution. Sometimes, though, we want to see the next line, or to move elsewhere
+in the file. This is done via the C<$incr>, C<$start>, and C<$max> variables.
-=head3 COMMAND LOOP TERMINATION
+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.
-When commands have finished executing, we come here. If the user closed the
-input filehandle, we turn on C<$fall_off_end> to emulate a C<q> command. We
-evaluate any post-prompt items. We restore C<$@>, C<$!>, C<$^E>, C<$,>, C<$/>,
-C<$\>, and C<$^W>, and return a null list as expected by the Perl interpreter.
-The interpreter will then execute the next line and then return control to us
-again.
+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.
-=cut
+C<$max> tells the debugger where the last line of the current file is. It's
+used to terminate loops most often.
- # No more commands? Quit.
- $fall_off_end = 1 unless defined $cmd; # Emulate 'q' on EOF
+=head2 THE COMMAND LOOP
- # Evaluate post-prompt commands.
- foreach $evalarg (@$post) {
- DB::eval();
- }
- } # if ($single || $signal)
+Most of C<DB::DB> is actually a command parsing and dispatch loop. It comes
+in two parts:
- # Put the user's globals back where you found them.
- ( $@, $!, $^E, $,, $/, $\, $^W ) = @saved;
- ();
-} ## end sub DB
+=over 4
-package DB::Obj;
+=item *
-sub new {
- my $class = shift;
+The outer part of the loop, starting at the C<CMD> label. This loop
+reads a command and then executes it.
- my $self = bless {}, $class;
+=item *
- $self->_init(@_);
+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.
- return $self;
-}
+=back
-sub _init {
- my ($self, $args) = @_;
+So why have two labels to restart the loop? Because sometimes, it's easier to
+have a command I<generate> another command and then re-execute the loop to do
+the new command. This is faster, but perhaps a bit more convoluted.
- %{$self} = (%$self, %$args);
+=cut
- return;
-}
+ # The big command dispatch loop. It keeps running until the
+ # user yields up control again.
+ #
+ # If we have a terminal for input, and we get something back
+ # from readline(), keep on processing.
-{
- no strict 'refs';
- foreach my $slot_name (qw(
- after explicit_stop infix pat piped position prefix selected cmd_verb
- cmd_args
- )) {
- my $slot = $slot_name;
- *{$slot} = sub {
- my $self = shift;
+ CMD:
+ while (_DB__read_next_cmd($tid))
+ {
- if (@_) {
- ${ $self->{$slot} } = shift;
- }
+ share($cmd);
+ # ... try to execute the input as debugger commands.
- return ${ $self->{$slot} };
- };
+ # Don't stop running.
+ $single = 0;
- *{"append_to_$slot"} = sub {
- my $self = shift;
- my $s = shift;
+ # No signal is active.
+ $signal = 0;
- return $self->$slot($self->$slot . $s);
- };
- }
-}
+ # Handle continued commands (ending with \):
+ if ($cmd =~ s/\\\z/\n/) {
+ $cmd .= DB::readline(" cont: ");
+ redo CMD;
+ }
-sub _DB_on_init__initialize_globals
-{
- my $self = shift;
+=head4 The null command
- # 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++ ) {
+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
+in the command history and fall through to allow the command parsing to pick
+it up.
- # Options say run non-stop. Run until we get an interrupt.
- if ($runnonstop) { # Disable until signal
- # If there's any call stack in place, turn off single
- # stepping into subs throughout the stack.
- for my $i (0 .. $stack_depth) {
- $stack[ $i ] &= ~1;
- }
+=cut
- # And we are now no longer in single-step mode.
- $single = 0;
+ # Empty input means repeat the last command.
+ if ($cmd eq '') {
+ $cmd = $laststep;
+ }
+ chomp($cmd); # get rid of the annoying extra newline
+ if (length($cmd) >= option_val('HistItemMinLength', 2)) {
+ push( @hist, $cmd );
+ }
+ push( @truehist, $cmd );
+ share(@hist);
+ share(@truehist);
- # If we simply returned at this point, we wouldn't get
- # the trace info. Fall on through.
- # return;
- } ## end if ($runnonstop)
+ # This is a restart point for commands that didn't arrive
+ # via direct user input. It allows us to 'redo PIPE' to
+ # re-execute command processing without reading a new command.
+ PIPE: {
+ _DB__trim_command_and_return_first_component($obj);
- elsif ($ImmediateStop) {
+=head3 COMMAND ALIASES
- # We are supposed to stop here; XXX probably a break.
- $ImmediateStop = 0; # We've processed it; turn it off
- $signal = 1; # Simulate an interrupt to force
- # us into the command loop
- }
- } ## end if ($single and not $second_time...
+The debugger can create aliases for commands (these are stored in the
+C<%alias> hash). Before a command is executed, the command loop looks it up
+in the alias hash and substitutes the contents of the alias for the command,
+completely replacing it.
- # If we're in single-step mode, or an interrupt (real or fake)
- # has occurred, turn off non-stop mode.
- $runnonstop = 0 if $single or $signal;
+=cut
- return;
-}
+ # See if there's an alias for the command, and set it up if so.
+ if ( $alias{$cmd_verb} ) {
-sub _DB__handle_watch_expressions
-{
- my $self = shift;
+ # Squelch signal handling; we want to keep control here
+ # if something goes loco during the alias eval.
+ local $SIG{__DIE__};
+ local $SIG{__WARN__};
- if ( $trace & 2 ) {
- for my $n (0 .. $#to_watch) {
- $evalarg = $to_watch[$n];
- local $onetimeDump; # Tell DB::eval() to not output results
+ # This is a command, so we eval it in the DEBUGGER's
+ # scope! Otherwise, we can't see the special debugger
+ # variables, or get to the debugger's subs. (Well, we
+ # _could_, but why make it even more complicated?)
+ eval "\$cmd =~ $alias{$cmd_verb}";
+ if ($@) {
+ local $\ = '';
+ print $OUT "Couldn't evaluate '$cmd_verb' alias: $@";
+ next CMD;
+ }
+ _DB__trim_command_and_return_first_component($obj);
+ } ## end if ($alias{$cmd_verb})
- # 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' );
+=head3 MAIN-LINE COMMANDS
- # Did it change?
- if ( $val ne $old_watch[$n] ) {
+All of these commands work up to and after the program being debugged has
+terminated.
- # 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)
+=head4 C<q> - quit
- return;
-}
+Quit the debugger. This entails setting the C<$fall_off_end> flag, so we don't
+try to execute further, cleaning any restart-related stuff out of the
+environment, and executing with the last value of C<$?>.
-sub _my_print_lineinfo
-{
- my ($self, $i, $incr_pos) = @_;
+=cut
- if ($frame) {
- # Print it indented if tracing is on.
- DB::print_lineinfo( ' ' x $stack_depth,
- "$i:\t$DB::dbline[$i]" . $self->after );
- }
- else {
- DB::depth_print_lineinfo($self->explicit_stop, $incr_pos);
- }
-}
+ # 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);
-sub _curr_line {
- return $DB::dbline[$line];
-}
+ 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);
+ }
+ }
-sub _is_full {
- my ($self, $letter) = @_;
+=head4 C<t> - trace [n]
- return ($DB::cmd eq $letter);
-}
+Turn tracing on or off. Inverts the appropriate bit in C<$trace> (q.v.).
+If level is specified, set C<$trace_to_depth>.
-sub _DB__grab_control
-{
- my $self = shift;
+=head4 C<S> - list subroutines matching/not matching a pattern
- # Yes, grab control.
- if ($slave_editor) {
+Walks through C<%sub>, checking to see whether or not to print the name.
- # Tell the editor to update its position.
- $self->position("\032\032${DB::filename}:$line:0\n");
- DB::print_lineinfo($self->position());
- }
+=head4 C<X> - list variables in current package
-=pod
+Since the C<V> command actually processes this, just change this to the
+appropriate C<V> command and fall through.
-Special check: if we're in package C<DB::fake>, we've gone through the
-C<END> block at least once. We set up everything so that we can continue
-to enter commands and have a valid context to be in.
+=head4 C<V> - list variables
-=cut
+Uses C<dumpvar.pl> to dump out the current values for selected variables.
- elsif ( $DB::package eq 'DB::fake' ) {
+=head4 C<x> - evaluate and print an expression
- # Fallen off the end already.
- if (!$DB::term) {
- DB::setterm();
- }
+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.
- DB::print_help(<<EOP);
-Debugged program terminated. Use B<q> to quit or B<R> to restart,
-use B<o> I<inhibit_exit> to avoid stopping after program termination,
-B<h q>, B<h R> or B<h o> to get additional info.
-EOP
+=head4 C<m> - print methods
- # Set the DB::eval context appropriately.
- $DB::package = 'main';
- $DB::usercontext = DB::_calc_usercontext($DB::package);
- } ## end elsif ($package eq 'DB::fake')
+Just uses C<DB::methods> to determine what methods are available.
-=pod
+=head4 C<f> - switch files
-If the program hasn't finished executing, we scan forward to the
-next executable line, print that out, build the prompt from the file and line
-number information, and print that.
+Switch to a different filename.
-=cut
+=head4 C<.> - return to last-executed line.
- else {
+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.
+=head4 C<-> - back one window
- # Still somewhere in the midst of execution. Set up the
- # debugger prompt.
- $DB::sub =~ s/\'/::/; # Swap Perl 4 package separators (') to
- # Perl 5 ones (sorry, we don't print Klingon
- #module names)
+We change C<$start> to be one window back; if we go back past the first line,
+we set it to be the first line. We set C<$incr> to put us back at the
+currently-executing line, and then put a C<l $start +> (list one window from
+C<$start>) in C<$cmd> to be executed later.
- $self->prefix($DB::sub =~ /::/ ? "" : ($DB::package . '::'));
- $self->append_to_prefix( "$DB::sub(${DB::filename}:" );
- $self->after( $self->_curr_line =~ /\n$/ ? '' : "\n" );
+=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>>
- # Break up the prompt if it's really long.
- if ( length($self->prefix()) > 30 ) {
- $self->position($self->prefix . "$line):\n$line:\t" . $self->_curr_line . $self->after);
- $self->prefix("");
- $self->infix(":\t");
- }
- else {
- $self->infix("):\t");
- $self->position(
- $self->prefix . $line. $self->infix
- . $self->_curr_line . $self->after
- );
- }
+In Perl 5.8.0, a realignment of the commands was done to fix up a number of
+problems, most notably that the default case of several commands destroying
+the user's work in setting watchpoints, actions, etc. We wanted, however, to
+retain the old commands for those who were used to using them or who preferred
+them. At this point, we check for the new commands and call C<cmd_wrapper> to
+deal with them instead of processing them in-line.
- # Print current line info, indenting if necessary.
- $self->_my_print_lineinfo($line, $self->position);
+=head4 C<y> - List lexicals in higher scope
- my $i;
- my $line_i = sub { return $DB::dbline[$i]; };
+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>.
- # Scan forward, stopping at either the end or the next
- # unbreakable line.
- for ( $i = $line + 1 ; $i <= $DB::max && $line_i->() == 0 ; ++$i )
- { #{ vi
+=head3 COMMANDS NOT WORKING AFTER PROGRAM ENDS
- # Drop out on null statements, block closers, and comments.
- last if $line_i->() =~ /^\s*[\;\}\#\n]/;
+All of the commands below this point don't work after the program being
+debugged has ended. All of them check to see if the program has ended; this
+allows the commands to be relocated without worrying about a 'line of
+demarcation' above which commands can be entered anytime, and below which
+they can't.
- # Drop out if the user interrupted us.
- last if $signal;
+=head4 C<n> - single step, but don't trace down into subs
- # Append a newline if the line doesn't have one. Can happen
- # in eval'ed text, for instance.
- $self->after( $line_i->() =~ /\n$/ ? '' : "\n" );
+Done by setting C<$single> to 2, which forces subs to execute straight through
+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.
- # Next executable line.
- my $incr_pos = $self->prefix . $i . $self->infix . $line_i->()
- . $self->after;
- $self->append_to_position($incr_pos);
- $self->_my_print_lineinfo($i, $incr_pos);
- } ## end for ($i = $line + 1 ; $i...
- } ## end else [ if ($slave_editor)
+=head4 C<s> - single-step, entering subs
- return;
-}
+Sets C<$single> to 1, which causes C<DB::sub> to continue tracing inside
+subs. Also saves C<s> as C<$lastcmd>.
-sub _handle_t_command {
- my $self = shift;
+=head4 C<c> - run continuously, setting an optional breakpoint
- my $levels = $self->cmd_args();
+Most of the code for this command is taken up with locating the optional
+breakpoint, which is either a subroutine name or a line number. We set
+the appropriate one-time-break in C<@dbline> and then turn off single-stepping
+in this and all call levels above this one.
- if ((!length($levels)) or ($levels !~ /\D/)) {
- $trace ^= 1;
- local $\ = '';
- $DB::trace_to_depth = $levels ? $stack_depth + $levels : 1E9;
- print {$OUT} "Trace = "
- . ( ( $trace & 1 )
- ? ( $levels ? "on (to level $DB::trace_to_depth)" : "on" )
- : "off" ) . "\n";
- next CMD;
- }
+=head4 C<r> - return from a subroutine
- return;
-}
+For C<r> to work properly, the debugger has to stop execution again
+immediately after the return is executed. This is done by forcing
+single-stepping to be on in the call level above the current one. If
+we are printing return values when a C<r> is executed, set C<$doret>
+appropriately, and force us out of the command loop.
+=head4 C<T> - stack trace
-sub _handle_S_command {
- my $self = shift;
+Just calls C<DB::print_trace>.
- if (my ($print_all_subs, $should_reverse, $Spatt)
- = $self->cmd_args =~ /\A((!)?(.+))?\z/) {
- # $Spatt is the pattern (if any) to use.
- # Reverse scan?
- my $Srev = defined $should_reverse;
- # No args - print all subs.
- my $Snocheck = !defined $print_all_subs;
+=head4 C<w> - List window around current line.
- # Need to make these sane here.
- local $\ = '';
- local $, = '';
+Just calls C<DB::cmd_w>.
- # Search through the debugger's magical hash of subs.
- # If $nocheck is true, just print the sub name.
- # Otherwise, check it against the pattern. We then use
- # the XOR trick to reverse the condition as required.
- foreach $subname ( sort( keys %sub ) ) {
- if ( $Snocheck or $Srev ^ ( $subname =~ /$Spatt/ ) ) {
- print $OUT $subname, "\n";
- }
- }
- next CMD;
- }
+=head4 C<W> - watch-expression processing.
- return;
-}
+Just calls C<DB::cmd_W>.
-sub _handle_V_command_and_X_command {
- my $self = shift;
+=head4 C</> - search forward for a string in the source
- $DB::cmd =~ s/^X\b/V $DB::package/;
+We take the argument and treat it as a pattern. If it turns out to be a
+bad one, we return the error we got from trying to C<eval> it and exit.
+If not, we create some code to do the search and C<eval> it so it can't
+mess us up.
- # Bare V commands get the currently-being-debugged package
- # added.
- if ($self->_is_full('V')) {
- $DB::cmd = "V $DB::package";
- }
+=cut
- # V - show variables in package.
- if (my ($new_packname, $new_vars_str) =
- $DB::cmd =~ /\AV\b\s*(\S+)\s*(.*)/) {
+ _DB__handle_forward_slash_command($obj);
- # Save the currently selected filehandle and
- # force output to debugger's filehandle (dumpvar
- # just does "print" for output).
- my $savout = select($OUT);
+=head4 C<?> - search backward for a string in the source
+
+Same as for C</>, except the loop runs backwards.
- # Grab package name and variables to dump.
- $packname = $new_packname;
- my @vars = split( ' ', $new_vars_str );
+=cut
- # If main::dumpvar isn't here, get it.
- do 'dumpvar.pl' || die $@ unless defined &main::dumpvar;
- if ( defined &main::dumpvar ) {
+ _DB__handle_question_mark_command($obj);
- # We got it. Turn off subroutine entry/exit messages
- # for the moment, along with return values.
- local $frame = 0;
- local $doret = -2;
+=head4 C<$rc> - Recall command
- # must detect sigpipe failures - not catching
- # then will cause the debugger to die.
- eval {
- main::dumpvar(
- $packname,
- defined $option{dumpDepth}
- ? $option{dumpDepth}
- : -1, # assume -1 unless specified
- @vars
- );
- };
+Manages the commands in C<@hist> (which is created if C<Term::ReadLine> reports
+that the terminal supports history). It finds the command required, puts it
+into C<$cmd>, and redoes the loop to execute it.
- # The die doesn't need to include the $@, because
- # it will automatically get propagated for us.
- if ($@) {
- die unless $@ =~ /dumpvar print failed/;
- }
- } ## end if (defined &main::dumpvar)
- else {
+=cut
- # Couldn't load dumpvar.
- print $OUT "dumpvar.pl not available.\n";
- }
+ # $rc - recall command.
+ $obj->_handle_rc_recall_command;
- # Restore the output filehandle, and go round again.
- select($savout);
- next CMD;
- }
+=head4 C<$sh$sh> - C<system()> command
- return;
-}
+Calls the C<_db_system()> to handle the command. This keeps the C<STDIN> and
+C<STDOUT> from getting messed up.
-sub _handle_dash_command {
- my $self = shift;
+=cut
- if ($self->_is_full('-')) {
+ $obj->_handle_sh_command;
- # back up by a window; go to 1 if back too far.
- $start -= $incr + $window + 1;
- $start = 1 if $start <= 0;
- $incr = $window - 1;
+=head4 C<$rc I<pattern> $rc> - Search command history
- # Generate and execute a "l +" command (handled below).
- $DB::cmd = 'l ' . ($start) . '+';
- redo CMD;
- }
- return;
-}
+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 C<redo>.
-sub _n_or_s_commands_generic {
- my ($self, $new_val) = @_;
- # n - next
- next CMD if DB::_DB__is_finished();
+=cut
- # Single step, but don't enter subs.
- $single = $new_val;
+ $obj->_handle_rc_search_history_command;
- # Save for empty command (repeat last).
- $laststep = $DB::cmd;
- last CMD;
-}
+=head4 C<$sh> - Invoke a shell
-sub _n_or_s {
- my ($self, $letter, $new_val) = @_;
+Uses C<_db_system()> to invoke a shell.
- if ($self->_is_full($letter)) {
- $self->_n_or_s_commands_generic($new_val);
- }
- else {
- $self->_n_or_s_and_arg_commands_generic($letter, $new_val);
- }
+=cut
- return;
-}
+=head4 C<$sh I<command>> - Force execution of a command in a shell
-sub _handle_n_command {
- my $self = shift;
+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>.
- return $self->_n_or_s('n', 2);
-}
+=head4 C<H> - display commands in history
-sub _handle_s_command {
- my $self = shift;
+Prints the contents of C<@hist> (if any).
- return $self->_n_or_s('s', 1);
-}
+=head4 C<man, doc, perldoc> - look up documentation
-sub _handle_r_command {
- my $self = shift;
+Just calls C<runman()> to print the appropriate document.
- # r - return from the current subroutine.
- if ($self->_is_full('r')) {
+=cut
- # Can't do anything if the program's over.
- next CMD if DB::_DB__is_finished();
+ $obj->_handle_doc_command;
- # Turn on stack trace.
- $stack[$stack_depth] |= 1;
+=head4 C<p> - print
- # Print return value unless the stack is empty.
- $doret = $option{PrintRet} ? $stack_depth - 1 : -2;
- last CMD;
- }
+Builds a C<print EXPR> expression in the C<$cmd>; this will get executed at
+the bottom of the loop.
- return;
-}
+=head4 C<=> - define command alias
-sub _handle_T_command {
- my $self = shift;
+Manipulates C<%alias> to add or list command aliases.
- if ($self->_is_full('T')) {
- DB::print_trace( $OUT, 1 ); # skip DB
- next CMD;
- }
+=head4 C<source> - read commands from a file.
- return;
-}
+Opens a lexical filehandle and stacks it on C<@cmdfhs>; C<DB::readline> will
+pick it up.
-sub _handle_w_command {
- my $self = shift;
+=head4 C<enable> C<disable> - enable or disable breakpoints
- DB::cmd_w( 'w', $self->cmd_args() );
- next CMD;
+This enables or disables breakpoints.
- return;
-}
+=head4 C<save> - send current history to a file
-sub _handle_W_command {
- my $self = shift;
+Takes the complete history, (not the shrunken version you see with C<H>),
+and saves it to the given filename, so it can be replayed using C<source>.
- if (my $arg = $self->cmd_args) {
- DB::cmd_W( 'W', $arg );
- next CMD;
- }
+Note that all C<^(save|source)>'s are commented out with a view to minimise recursion.
- return;
-}
+=head4 C<R> - restart
-sub _handle_rc_recall_command {
- my $self = shift;
+Restart the debugger session.
- # $rc - recall command.
- if (my ($minus, $arg) = $DB::cmd =~ m#\A$rc+\s*(-)?(\d+)?\z#) {
+=head4 C<rerun> - rerun the current session
- # No arguments, take one thing off history.
- pop(@hist) if length($DB::cmd) > 1;
+Return to any given position in the B<true>-history list
- # Relative (- found)?
- # Y - index back from most recent (by 1 if bare minus)
- # N - go to that particular command slot or the last
- # thing if nothing following.
+=head4 C<|, ||> - pipe output through the pager.
- $self->cmd_verb(
- scalar($minus ? ( $#hist - ( $arg || 1 ) ) : ( $arg || $#hist ))
- );
+For C<|>, we save C<OUT> (the debugger's output filehandle) and C<STDOUT>
+(the program's standard output). For C<||>, we only save C<OUT>. We open a
+pipe to the pager (restoring the output filehandles if this fails). If this
+is the C<|> command, we also set up a C<SIGPIPE> handler which will simply
+set C<$signal>, sending us back into the debugger.
- # Pick out the command desired.
- $DB::cmd = $hist[$self->cmd_verb];
+We then trim off the pipe symbols and C<redo> the command loop at the
+C<PIPE> label, causing us to evaluate the command in C<$cmd> without
+reading another.
- # Print the command to be executed and restart the loop
- # with that command in the buffer.
- print {$OUT} $DB::cmd, "\n";
- redo CMD;
- }
+=cut
- return;
-}
+ # || - run command in the pager, with output to DB::OUT.
+ _DB__handle_run_command_in_pager_command($obj);
-sub _handle_rc_search_history_command {
- my $self = shift;
+=head3 END OF COMMAND PARSING
- # $rc pattern $rc - find a command in the history.
- if (my ($arg) = $DB::cmd =~ /\A$rc([^$rc].*)\z/) {
+Anything left in C<$cmd> at this point is a Perl expression that we want to
+evaluate. We'll always evaluate in the user's context, and fully qualify
+any variables we might want to address in the C<DB> package.
- # Create the pattern to use.
- my $pat = "^$arg";
- $self->pat($pat);
+=cut
- # Toss off last entry if length is >1 (and it always is).
- pop(@hist) if length($DB::cmd) > 1;
+ } # PIPE:
- my $i;
+ # trace an expression
+ $cmd =~ s/^t\s/\$DB::trace |= 1;\n/;
- # Look backward through the history.
- SEARCH_HIST:
- for ( $i = $#hist ; $i ; --$i ) {
- # Stop if we find it.
- last SEARCH_HIST if $hist[$i] =~ /$pat/;
- }
+ # 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";
- if ( !$i ) {
+ # Run *our* eval that executes in the caller's context.
+ # The &-call is here to ascertain the mutability of @_.
+ &DB::eval;
- # Never found it.
- print $OUT "No such command!\n\n";
- next CMD;
- }
+ # 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();
+ };
- # Found it. Put it in the buffer, print it, and process it.
- $DB::cmd = $hist[$i];
- print $OUT $DB::cmd, "\n";
- redo CMD;
- }
+ # XXX If this is the master pid, print a newline.
+ print {$OUT} "\n";
+ }
+ } ## end while (($term || &setterm...
- return;
-}
+=head3 POST-COMMAND PROCESSING
-sub _handle_H_command {
- my $self = shift;
+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.
- if ($self->cmd_args =~ m#\A\*#) {
- @hist = @truehist = ();
- print $OUT "History cleansed\n";
- next CMD;
- }
+=cut
- if (my ($num) = $self->cmd_args =~ /\A(?:-(\d+))?/) {
+ continue { # CMD:
+ _DB__at_end_of_every_command($obj);
+ } # CMD:
- # Anything other than negative numbers is ignored by
- # the (incorrect) pattern, so this test does nothing.
- $end = $num ? ( $#hist - $num ) : 0;
+=head3 COMMAND LOOP TERMINATION
- # Set to the minimum if less than zero.
- $hist = 0 if $hist < 0;
+When commands have finished executing, we come here. If the user closed the
+input filehandle, we turn on C<$fall_off_end> to emulate a C<q> command. We
+evaluate any post-prompt items. We restore C<$@>, C<$!>, C<$^E>, C<$,>, C<$/>,
+C<$\>, and C<$^W>, and return a null list as expected by the Perl interpreter.
+The interpreter will then execute the next line and then return control to us
+again.
- # Start at the end of the array.
- # Stay in while we're still above the ending value.
- # Tick back by one each time around the loop.
- my $i;
+=cut
- for ( $i = $#hist ; $i > $end ; $i-- ) {
+ # No more commands? Quit.
+ $fall_off_end = 1 unless defined $cmd; # Emulate 'q' on EOF
- # Print the command unless it has no arguments.
- print $OUT "$i: ", $hist[$i], "\n"
- unless $hist[$i] =~ /^.?$/;
+ # Evaluate post-prompt commands.
+ foreach $evalarg (@$post) {
+ # The &-call is here to ascertain the mutability of @_.
+ &DB::eval;
}
+ } # if ($single || $signal)
- next CMD;
- }
-
- return;
-}
+ # Put the user's globals back where you found them.
+ ( $@, $!, $^E, $,, $/, $\, $^W ) = @saved;
+ ();
+} ## end sub DB
-sub _handle_doc_command {
- my $self = shift;
+# 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 {
- # man, perldoc, doc - show manual pages.
- if (my ($man_page)
- = $DB::cmd =~ /\A(?:man|(?:perl)?doc)\b(?:\s+([^(]*))?\z/) {
- runman($man_page);
- next CMD;
- }
+package DB::Obj;
- return;
-}
+sub new {
+ my $class = shift;
-sub _handle_p_command {
- my $self = shift;
+ my $self = bless {}, $class;
- my $print_cmd = 'print {$DB::OUT} ';
- # p - print (no args): print $_.
- if ($self->_is_full('p')) {
- $DB::cmd = $print_cmd . '$_';
- }
- else {
- # p - print the given expression.
- $DB::cmd =~ s/\Ap\b/$print_cmd /;
- }
+ $self->_init(@_);
- return;
+ return $self;
}
-sub _handle_equal_sign_command {
- my $self = shift;
-
- if ($DB::cmd =~ s/\A=\s*//) {
- my @keys;
- if ( length $DB::cmd == 0 ) {
+sub _init {
+ my ($self, $args) = @_;
- # No args, get current aliases.
- @keys = sort keys %alias;
- }
- elsif ( my ( $k, $v ) = ( $DB::cmd =~ /^(\S+)\s+(\S.*)/ ) ) {
+ %{$self} = (%$self, %$args);
- # Creating a new alias. $k is alias name, $v is
- # alias value.
+ return;
+}
- # can't use $_ or kill //g state
- for my $x ( $k, $v ) {
+{
+ no strict 'refs';
+ foreach my $slot_name (qw(
+ after explicit_stop infix pat piped position prefix selected cmd_verb
+ cmd_args
+ )) {
+ my $slot = $slot_name;
+ *{$slot} = sub {
+ my $self = shift;
- # Escape "alarm" characters.
- $x =~ s/\a/\\a/g;
+ if (@_) {
+ ${ $self->{$slot} } = shift;
}
- # 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";
+ return ${ $self->{$slot} };
+ };
- # Turn off standard warn and die behavior.
- local $SIG{__DIE__};
- local $SIG{__WARN__};
+ *{"append_to_$slot"} = sub {
+ my $self = shift;
+ my $s = shift;
- # Is it valid Perl?
- unless ( eval "sub { s\a$k\a$v\a }; 1" ) {
+ return $self->$slot($self->$slot . $s);
+ };
+ }
+}
- # Nope. Bad alias. Say so and get out.
- print $OUT "Can't alias $k to $v: $@\n";
- delete $alias{$k};
- next CMD;
- }
+sub _DB_on_init__initialize_globals
+{
+ my $self = shift;
- # We'll only list the new one.
- @keys = ($k);
- } ## end elsif (my ($k, $v) = ($DB::cmd...
+ # 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 argument is the alias to list.
- else {
- @keys = ($DB::cmd);
- }
+ # Options say run non-stop. Run until we get an interrupt.
+ if ($runnonstop) { # Disable until signal
+ # If there's any call stack in place, turn off single
+ # stepping into subs throughout the stack.
+ for my $i (0 .. $stack_depth) {
+ $stack[ $i ] &= ~1;
+ }
- # List aliases.
- for my $k (@keys) {
+ # And we are now no longer in single-step mode.
+ $single = 0;
- # 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} ) =~ s\as\a$k\a(.*)\a$\a1\a ) {
+ # If we simply returned at this point, we wouldn't get
+ # the trace info. Fall on through.
+ # return;
+ } ## end if ($runnonstop)
- # Print the alias.
- print $OUT "$k\t= $1\n";
- }
- elsif ( defined $alias{$k} ) {
+ elsif ($ImmediateStop) {
- # Couldn't trim it off; just print the alias code.
- print $OUT "$k\t$alias{$k}\n";
- }
- else {
+ # We are supposed to stop here; XXX probably a break.
+ $ImmediateStop = 0; # We've processed it; turn it off
+ $signal = 1; # Simulate an interrupt to force
+ # us into the command loop
+ }
+ } ## end if ($single and not $second_time...
- # No such, dude.
- print "No alias for $k\n";
- }
- } ## end for my $k (@keys)
- next CMD;
- }
+ # If we're in single-step mode, or an interrupt (real or fake)
+ # has occurred, turn off non-stop mode.
+ $runnonstop = 0 if $single or $signal;
return;
}
-sub _handle_source_command {
- my $self = shift;
-
- # source - read commands from a file (or pipe!) and execute.
- if (my $sourced_fn = $self->cmd_args) {
- if ( open my $fh, $sourced_fn ) {
-
- # Opened OK; stick it in the list of file handles.
- push @cmdfhs, $fh;
- }
- else {
+sub _my_print_lineinfo
+{
+ my ($self, $i, $incr_pos) = @_;
- # Couldn't open it.
- DB::_db_warn("Can't execute '$sourced_fn': $!\n");
- }
- next CMD;
+ if ($frame) {
+ # Print it indented if tracing is on.
+ DB::print_lineinfo( ' ' x $stack_depth,
+ "$i:\t$DB::dbline[$i]" . $self->after );
+ }
+ else {
+ DB::depth_print_lineinfo($self->explicit_stop, $incr_pos);
}
+}
- return;
+sub _curr_line {
+ return $DB::dbline[$line];
}
-sub _handle_enable_disable_commands {
- my $self = shift;
+sub _is_full {
+ my ($self, $letter) = @_;
- my $which_cmd = $self->cmd_verb;
- my $position = $self->cmd_args;
+ return ($DB::cmd eq $letter);
+}
- if ($position !~ /\s/) {
- my ($fn, $line_num);
- if ($position =~ m{\A\d+\z})
- {
- $fn = $DB::filename;
- $line_num = $position;
- }
- elsif (my ($new_fn, $new_line_num)
- = $position =~ m{\A(.*):(\d+)\z}) {
- ($fn, $line_num) = ($new_fn, $new_line_num);
- }
- else
- {
- DB::_db_warn("Wrong spec for enable/disable argument.\n");
- }
+sub _DB__grab_control
+{
+ my $self = shift;
- if (defined($fn)) {
- if (DB::_has_breakpoint_data_ref($fn, $line_num)) {
- DB::_set_breakpoint_enabled_status($fn, $line_num,
- ($which_cmd eq 'enable' ? 1 : '')
- );
- }
- else {
- DB::_db_warn("No breakpoint set at ${fn}:${line_num}\n");
- }
- }
+ # Yes, grab control.
+ if ($slave_editor) {
- next CMD;
+ # Tell the editor to update its position.
+ $self->position("\032\032${DB::filename}:$line:0\n");
+ DB::print_lineinfo($self->position());
}
- return;
-}
+=pod
-sub _handle_save_command {
- my $self = shift;
+Special check: if we're in package C<DB::fake>, we've gone through the
+C<END> block at least once. We set up everything so that we can continue
+to enter commands and have a valid context to be in.
- if (my $new_fn = $self->cmd_args) {
- my $filename = $new_fn || '.perl5dbrc'; # default?
- if ( open my $fh, '>', $filename ) {
+=cut
- # chomp to remove extraneous newlines from source'd files
- chomp( my @truelist =
- map { m/\A\s*(save|source)/ ? "#$_" : $_ }
- @truehist );
- print {$fh} join( "\n", @truelist );
- print "commands saved in $filename\n";
- }
- else {
- DB::_db_warn("Can't save debugger commands in '$new_fn': $!\n");
+ elsif ( $DB::package eq 'DB::fake' ) {
+
+ # Fallen off the end already.
+ if (!$DB::term) {
+ DB::setterm();
}
- next CMD;
- }
- return;
-}
+ DB::print_help(<<EOP);
+Debugged program terminated. Use B<q> to quit or B<R> to restart,
+use B<o> I<inhibit_exit> to avoid stopping after program termination,
+B<h q>, B<h R> or B<h o> to get additional info.
+EOP
-sub _n_or_s_and_arg_commands_generic {
- my ($self, $letter, $new_val) = @_;
+ $DB::package = 'main';
+ $DB::usercontext = DB::_calc_usercontext($DB::package);
+ } ## end elsif ($package eq 'DB::fake')
- # s - single-step. Remember the last command was 's'.
- if ($DB::cmd =~ s#\A\Q$letter\E\s#\$DB::single = $new_val;\n#) {
- $laststep = $letter;
- }
+=pod
- return;
-}
+If the program hasn't finished executing, we scan forward to the
+next executable line, print that out, build the prompt from the file and line
+number information, and print that.
-sub _handle_sh_command {
- my $self = shift;
+=cut
- # $sh$sh - run a shell command (if it's all ASCII).
- # Can't run shell commands with Unicode in the debugger, hmm.
- my $my_cmd = $DB::cmd;
- if ($my_cmd =~ m#\A$sh#gms) {
+ else {
- 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::_db_system( $ENV{SHELL} || "/bin/sh" );
- next CMD;
- }
- elsif ($my_cmd =~ m#\G$sh\s*(.*)#cgms) {
- # System it.
- DB::_db_system($1);
- next CMD;
+
+ # Still somewhere in the midst of execution. Set up the
+ # debugger prompt.
+ $DB::sub =~ s/\'/::/; # Swap Perl 4 package separators (') to
+ # Perl 5 ones (sorry, we don't print Klingon
+ #module names)
+
+ $self->prefix($DB::sub =~ /::/ ? "" : ($DB::package . '::'));
+ $self->append_to_prefix( "$DB::sub(${DB::filename}:" );
+ $self->after( $self->_curr_line =~ /\n$/ ? '' : "\n" );
+
+ # Break up the prompt if it's really long.
+ if ( length($self->prefix()) > 30 ) {
+ $self->position($self->prefix . "$line):\n$line:\t" . $self->_curr_line . $self->after);
+ $self->prefix("");
+ $self->infix(":\t");
}
- elsif ($my_cmd =~ m#\G\s*(.*)#cgms) {
- DB::_db_system( $ENV{SHELL} || "/bin/sh", "-c", $1 );
- next CMD;
+ else {
+ $self->infix("):\t");
+ $self->position(
+ $self->prefix . $line. $self->infix
+ . $self->_curr_line . $self->after
+ );
}
- }
-}
-sub _handle_x_command {
- my $self = shift;
+ # Print current line info, indenting if necessary.
+ $self->_my_print_lineinfo($line, $self->position);
- if ($DB::cmd =~ s#\Ax\b# #) { # Remainder gets done by DB::eval()
- $onetimeDump = 'dump'; # main::dumpvar shows the output
+ my $i;
+ my $line_i = sub { return $DB::dbline[$i]; };
- # handle special "x 3 blah" syntax XXX propagate
- # doc back to special variables.
- if ( $DB::cmd =~ s#\A\s*(\d+)(?=\s)# #) {
- $onetimedumpDepth = $1;
- }
- }
+ # Scan forward, stopping at either the end or the next
+ # unbreakable line.
+ for ( $i = $line + 1 ; $i <= $DB::max && $line_i->() == 0 ; ++$i )
+ { #{ vi
+
+ # Drop out on null statements, block closers, and comments.
+ last if $line_i->() =~ /^\s*[\;\}\#\n]/;
+
+ # Drop out if the user interrupted us.
+ last if $signal;
+
+ # Append a newline if the line doesn't have one. Can happen
+ # in eval'ed text, for instance.
+ $self->after( $line_i->() =~ /\n$/ ? '' : "\n" );
+
+ # Next executable line.
+ my $incr_pos = $self->prefix . $i . $self->infix . $line_i->()
+ . $self->after;
+ $self->append_to_position($incr_pos);
+ $self->_my_print_lineinfo($i, $incr_pos);
+ } ## end for ($i = $line + 1 ; $i...
+ } ## end else [ if ($slave_editor)
return;
}
-sub _handle_q_command {
+sub _handle_t_command {
my $self = shift;
- if ($self->_is_full('q')) {
- $fall_off_end = 1;
- DB::clean_ENV();
- exit $?;
+ my $levels = $self->cmd_args();
+
+ if ((!length($levels)) or ($levels !~ /\D/)) {
+ $trace ^= 1;
+ local $\ = '';
+ $DB::trace_to_depth = $levels ? $stack_depth + $levels : 1E9;
+ print {$OUT} "Trace = "
+ . ( ( $trace & 1 )
+ ? ( $levels ? "on (to level $DB::trace_to_depth)" : "on" )
+ : "off" ) . "\n";
+ next CMD;
}
return;
}
-sub _handle_cmd_wrapper_commands {
+
+sub _handle_S_command {
my $self = shift;
- DB::cmd_wrapper( $self->cmd_verb, $self->cmd_args, $line );
- next CMD;
-}
+ if (my ($print_all_subs, $should_reverse, $Spatt)
+ = $self->cmd_args =~ /\A((!)?(.+))?\z/) {
+ # $Spatt is the pattern (if any) to use.
+ # Reverse scan?
+ my $Srev = defined $should_reverse;
+ # No args - print all subs.
+ my $Snocheck = !defined $print_all_subs;
-sub _handle_special_char_cmd_wrapper_commands {
- my $self = shift;
+ # Need to make these sane here.
+ local $\ = '';
+ local $, = '';
- # 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 );
+ # Search through the debugger's magical hash of subs.
+ # If $nocheck is true, just print the sub name.
+ # Otherwise, check it against the pattern. We then use
+ # the XOR trick to reverse the condition as required.
+ foreach $subname ( sort( keys %sub ) ) {
+ if ( $Snocheck or $Srev ^ ( $subname =~ /$Spatt/ ) ) {
+ print $OUT $subname, "\n";
+ }
+ }
next CMD;
}
return;
}
-package DB;
+sub _handle_V_command_and_X_command {
+ my $self = shift;
-# The following code may be executed now:
-# BEGIN {warn 4}
+ $DB::cmd =~ s/^X\b/V $DB::package/;
-=head2 sub
+ # Bare V commands get the currently-being-debugged package
+ # added.
+ if ($self->_is_full('V')) {
+ $DB::cmd = "V $DB::package";
+ }
-C<sub> is called whenever a subroutine call happens in the program being
-debugged. The variable C<$DB::sub> contains the name of the subroutine
-being called.
+ # V - show variables in package.
+ if (my ($new_packname, $new_vars_str) =
+ $DB::cmd =~ /\AV\b\s*(\S+)\s*(.*)/) {
-The core function of this subroutine is to actually call the sub in the proper
-context, capturing its output. This of course causes C<DB::DB> to get called
-again, repeating until the subroutine ends and returns control to C<DB::sub>
-again. Once control returns, C<DB::sub> figures out whether or not to dump the
-return value, and returns its captured copy of the return value as its own
-return value. The value then feeds back into the program being debugged as if
-C<DB::sub> hadn't been there at all.
+ # Save the currently selected filehandle and
+ # force output to debugger's filehandle (dumpvar
+ # just does "print" for output).
+ my $savout = select($OUT);
-C<sub> does all the work of printing the subroutine entry and exit messages
-enabled by setting C<$frame>. It notes what sub the autoloader got called for,
-and also prints the return value if needed (for the C<r> command and if
-the 16 bit is set in C<$frame>).
+ # Grab package name and variables to dump.
+ $packname = $new_packname;
+ my @vars = split( ' ', $new_vars_str );
-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 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.
+ # If main::dumpvar isn't here, get it.
+ do 'dumpvar.pl' || die $@ unless defined &main::dumpvar;
+ if ( defined &main::dumpvar ) {
-=head3 C<caller()> support
+ # We got it. Turn off subroutine entry/exit messages
+ # for the moment, along with return values.
+ local $frame = 0;
+ local $doret = -2;
-If C<caller()> is called from the package C<DB>, it provides some
-additional data, in the following order:
+ # must detect sigpipe failures - not catching
+ # then will cause the debugger to die.
+ eval {
+ main::dumpvar(
+ $packname,
+ defined $option{dumpDepth}
+ ? $option{dumpDepth}
+ : -1, # assume -1 unless specified
+ @vars
+ );
+ };
+
+ # The die doesn't need to include the $@, because
+ # it will automatically get propagated for us.
+ if ($@) {
+ die unless $@ =~ /dumpvar print failed/;
+ }
+ } ## end if (defined &main::dumpvar)
+ else {
+
+ # Couldn't load dumpvar.
+ print $OUT "dumpvar.pl not available.\n";
+ }
+
+ # Restore the output filehandle, and go round again.
+ select($savout);
+ next CMD;
+ }
-=over 4
+ return;
+}
-=item * C<$package>
+sub _handle_dash_command {
+ my $self = shift;
-The package name the sub was in
+ if ($self->_is_full('-')) {
-=item * C<$filename>
+ # back up by a window; go to 1 if back too far.
+ $start -= $incr + $window + 1;
+ $start = 1 if $start <= 0;
+ $incr = $window - 1;
-The filename it was defined in
+ # Generate and execute a "l +" command (handled below).
+ $DB::cmd = 'l ' . ($start) . '+';
+ redo CMD;
+ }
+ return;
+}
-=item * C<$line>
+sub _n_or_s_commands_generic {
+ my ($self, $new_val) = @_;
+ # n - next
+ next CMD if DB::_DB__is_finished();
-The line number it was defined on
+ # Single step, but don't enter subs.
+ $single = $new_val;
-=item * C<$subroutine>
+ # Save for empty command (repeat last).
+ $laststep = $DB::cmd;
+ last CMD;
+}
-The subroutine name; C<(eval)> if an C<eval>().
+sub _n_or_s {
+ my ($self, $letter, $new_val) = @_;
-=item * C<$hasargs>
+ if ($self->_is_full($letter)) {
+ $self->_n_or_s_commands_generic($new_val);
+ }
+ else {
+ $self->_n_or_s_and_arg_commands_generic($letter, $new_val);
+ }
-1 if it has arguments, 0 if not
+ return;
+}
-=item * C<$wantarray>
+sub _handle_n_command {
+ my $self = shift;
-1 if array context, 0 if scalar context
+ return $self->_n_or_s('n', 2);
+}
-=item * C<$evaltext>
+sub _handle_s_command {
+ my $self = shift;
-The C<eval>() text, if any (undefined for C<eval BLOCK>)
+ return $self->_n_or_s('s', 1);
+}
-=item * C<$is_require>
+sub _handle_r_command {
+ my $self = shift;
-frame was created by a C<use> or C<require> statement
+ # r - return from the current subroutine.
+ if ($self->_is_full('r')) {
-=item * C<$hints>
+ # Can't do anything if the program's over.
+ next CMD if DB::_DB__is_finished();
-pragma information; subject to change between versions
+ # Turn on stack trace.
+ $stack[$stack_depth] |= 1;
-=item * C<$bitmask>
+ # Print return value unless the stack is empty.
+ $doret = $option{PrintRet} ? $stack_depth - 1 : -2;
+ last CMD;
+ }
-pragma information; subject to change between versions
+ return;
+}
-=item * C<@DB::args>
+sub _handle_T_command {
+ my $self = shift;
-arguments with which the subroutine was invoked
+ if ($self->_is_full('T')) {
+ DB::print_trace( $OUT, 1 ); # skip DB
+ next CMD;
+ }
-=back
+ return;
+}
-=cut
+sub _handle_w_command {
+ my $self = shift;
-use vars qw($deep);
+ DB::cmd_w( 'w', $self->cmd_args() );
+ next CMD;
-# We need to fully qualify the name ("DB::sub") to make "use strict;"
-# happy. -- Shlomi Fish
+ return;
+}
-sub _indent_print_line_info {
- my ($offset, $str) = @_;
+sub _handle_W_command {
+ my $self = shift;
- print_lineinfo( ' ' x ($stack_depth - $offset), $str);
+ if (my $arg = $self->cmd_args) {
+ DB::cmd_W( 'W', $arg );
+ next CMD;
+ }
return;
}
-sub _print_frame_message {
- my ($al) = @_;
+sub _handle_rc_recall_command {
+ my $self = shift;
- if ($frame) {
- if ($frame & 4) { # Extended frame entry message
- _indent_print_line_info(-1, "in ");
+ # $rc - recall command.
+ if (my ($minus, $arg) = $DB::cmd =~ m#\A$rc+\s*(-)?(\d+)?\z#) {
- # 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" );
- }
+ # No arguments, take one thing off history.
+ pop(@hist) if length($DB::cmd) > 1;
+
+ # Relative (- found)?
+ # Y - index back from most recent (by 1 if bare minus)
+ # N - go to that particular command slot or the last
+ # thing if nothing following.
+
+ $self->cmd_verb(
+ scalar($minus ? ( $#hist - ( $arg || 1 ) ) : ( $arg || $#hist ))
+ );
+
+ # Pick out the command desired.
+ $DB::cmd = $hist[$self->cmd_verb];
+
+ # Print the command to be executed and restart the loop
+ # with that command in the buffer.
+ print {$OUT} $DB::cmd, "\n";
+ redo CMD;
}
return;
}
-sub DB::sub {
- # Do not use a regex in this subroutine -> results in corrupted memory
- # See: [perl #66110]
+sub _handle_rc_search_history_command {
+ my $self = shift;
- # lock ourselves under threads
- lock($DBGR);
+ # $rc pattern $rc - find a command in the history.
+ if (my ($arg) = $DB::cmd =~ /\A$rc([^$rc].*)\z/) {
- # 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";
- }
+ # Create the pattern to use.
+ my $pat = "^$arg";
+ $self->pat($pat);
- # 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' ) {
- no strict 'refs';
- $al = " for $$sub" if defined $$sub;
- }
+ # Toss off last entry if length is >1 (and it always is).
+ pop(@hist) if length($DB::cmd) > 1;
- # 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
+ my $i;
- # Expand @stack.
- $#stack = $stack_depth;
+ # Look backward through the history.
+ SEARCH_HIST:
+ for ( $i = $#hist ; $i ; --$i ) {
+ # Stop if we find it.
+ last SEARCH_HIST if $hist[$i] =~ /$pat/;
+ }
- # Save current single-step setting.
- $stack[-1] = $single;
+ if ( !$i ) {
- # Turn off all flags except single-stepping.
- $single &= 1;
+ # Never found it.
+ print $OUT "No such command!\n\n";
+ next CMD;
+ }
+
+ # Found it. Put it in the buffer, print it, and process it.
+ $DB::cmd = $hist[$i];
+ print $OUT $DB::cmd, "\n";
+ redo CMD;
+ }
- # 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;
+ return;
+}
- # If frame messages are on ...
+sub _handle_H_command {
+ my $self = shift;
- _print_frame_message($al);
- # standard frame entry message
+ if ($self->cmd_args =~ m#\A\*#) {
+ @hist = @truehist = ();
+ print $OUT "History cleansed\n";
+ next CMD;
+ }
- 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;
- };
+ if (my ($num) = $self->cmd_args =~ /\A(?:-(\d+))?/) {
- # Determine the sub's return type, and capture appropriately.
- if (wantarray) {
+ # Anything other than negative numbers is ignored by
+ # the (incorrect) pattern, so this test does nothing.
+ $end = $num ? ( $#hist - $num ) : 0;
- # 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.
- {
- no strict 'refs';
- @ret = &$sub;
- }
+ # Set to the minimum if less than zero.
+ $hist = 0 if $hist < 0;
- # Pop the single-step value back off the stack.
- $single |= $stack[ $stack_depth-- ];
+ # Start at the end of the array.
+ # Stay in while we're still above the ending value.
+ # Tick back by one each time around the loop.
+ my $i;
- $print_exit_msg->();
+ for ( $i = $#hist ; $i > $end ; $i-- ) {
+ print $OUT "$i: ", $hist[$i], "\n";
+ }
- # Print the return info if we need to.
- if ( $doret eq $stack_depth or $frame & 16 ) {
+ next CMD;
+ }
- # Turn off output record separator.
- local $\ = '';
- my $fh = ( $doret eq $stack_depth ? $OUT : $LINEINFO );
+ return;
+}
- # Indent if we're printing because of $frame tracing.
- if ($frame & 16)
- {
- print {$fh} ' ' x $stack_depth;
- }
+sub _handle_doc_command {
+ my $self = shift;
- # Print the return value.
- print {$fh} "list context return from $sub:\n";
- dumpit( $fh, \@ret );
+ # man, perldoc, doc - show manual pages.
+ if (my ($man_page)
+ = $DB::cmd =~ /\A(?:man|(?:perl)?doc)\b(?:\s+([^(]*))?\z/) {
+ DB::runman($man_page);
+ next CMD;
+ }
- # And don't print it again.
- $doret = -2;
- } ## end if ($doret eq $stack_depth...
- # And we have to return the return value now.
- @ret;
- } ## end if (wantarray)
+ return;
+}
+
+sub _handle_p_command {
+ my $self = shift;
- # Scalar context.
+ my $print_cmd = 'print {$DB::OUT} ';
+ # p - print (no args): print $_.
+ if ($self->_is_full('p')) {
+ $DB::cmd = $print_cmd . '$_';
+ }
else {
- if ( defined wantarray ) {
- no strict 'refs';
- # Save the value if it's wanted at all.
- $ret = &$sub;
- }
- else {
- no strict 'refs';
- # Void return, explicitly.
- &$sub;
- undef $ret;
- }
+ # p - print the given expression.
+ $DB::cmd =~ s/\Ap\b/$print_cmd /;
+ }
- # Pop the single-step value off the stack.
- $single |= $stack[ $stack_depth-- ];
+ return;
+}
- # If we're doing exit messages...
- $print_exit_msg->();
+sub _handle_equal_sign_command {
+ my $self = shift;
- # If we are supposed to show the return value... same as before.
- if ( $doret eq $stack_depth or $frame & 16 and defined wantarray ) {
- local $\ = '';
- my $fh = ( $doret eq $stack_depth ? $OUT : $LINEINFO );
- print $fh ( ' ' x $stack_depth ) if $frame & 16;
- print $fh (
- defined wantarray
- ? "scalar context return from $sub: "
- : "void context return from $sub\n"
- );
- dumpit( $fh, $ret ) if defined wantarray;
- $doret = -2;
- } ## end if ($doret eq $stack_depth...
+ if ($DB::cmd =~ s/\A=\s*//) {
+ my @keys;
+ if ( length $DB::cmd == 0 ) {
- # Return the appropriate scalar value.
- $ret;
- } ## end else [ if (wantarray)
-} ## end sub _sub
+ # No args, get current aliases.
+ @keys = sort keys %alias;
+ }
+ elsif ( my ( $k, $v ) = ( $DB::cmd =~ /^(\S+)\s+(\S.*)/ ) ) {
-sub lsub : lvalue {
+ # Creating a new alias. $k is alias name, $v is
+ # alias value.
- no strict 'refs';
+ # can't use $_ or kill //g state
+ for my $x ( $k, $v ) {
- # lock ourselves under threads
- lock($DBGR);
+ # Escape "alarm" characters.
+ $x =~ s/\a/\\a/g;
+ }
- # 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";
- }
+ # 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";
- # 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";
- }
+ # Turn off standard warn and die behavior.
+ local $SIG{__DIE__};
+ local $SIG{__WARN__};
- # 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
+ # Is it valid Perl?
+ unless ( eval "sub { s\a$k\a$v\a }; 1" ) {
- # Expand @stack.
- $#stack = $stack_depth;
+ # Nope. Bad alias. Say so and get out.
+ print $OUT "Can't alias $k to $v: $@\n";
+ delete $alias{$k};
+ next CMD;
+ }
- # Save current single-step setting.
- $stack[-1] = $single;
+ # We'll only list the new one.
+ @keys = ($k);
+ } ## end elsif (my ($k, $v) = ($DB::cmd...
- # Turn off all flags except single-stepping.
- $single &= 1;
+ # The argument is the alias to list.
+ else {
+ @keys = ($DB::cmd);
+ }
- # 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;
+ # List aliases.
+ for my $k (@keys) {
- # If frame messages are on ...
- _print_frame_message($al);
+ # 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} ) =~ s\as\a$k\a(.*)\a$\a1\a ) {
- # Pop the single-step value back off the stack.
- $single |= $stack[ $stack_depth-- ];
+ # Print the alias.
+ print $OUT "$k\t= $1\n";
+ }
+ elsif ( defined $alias{$k} ) {
- # call the original lvalue sub.
- &$sub;
-}
+ # Couldn't trim it off; just print the alias code.
+ print $OUT "$k\t$alias{$k}\n";
+ }
+ else {
-# Abstracting common code from multiple places elsewhere:
-sub depth_print_lineinfo {
- my $always_print = shift;
+ # No such, dude.
+ print "No alias for $k\n";
+ }
+ } ## end for my $k (@keys)
+ next CMD;
+ }
- print_lineinfo( @_ ) if ($always_print or $stack_depth < $trace_to_depth);
+ return;
}
-=head1 EXTENDED COMMAND HANDLING AND THE COMMAND API
+sub _handle_source_command {
+ my $self = shift;
-In Perl 5.8.0, there was a major realignment of the commands and what they did,
-Most of the changes were to systematize the command structure and to eliminate
-commands that threw away user input without checking.
+ # source - read commands from a file (or pipe!) and execute.
+ if (my $sourced_fn = $self->cmd_args) {
+ if ( open my $fh, $sourced_fn ) {
-The following sections describe the code added to make it easy to support
-multiple command sets with conflicting command names. This section is a start
-at unifying all command processing to make it simpler to develop commands.
+ # Opened OK; stick it in the list of file handles.
+ push @cmdfhs, $fh;
+ }
+ else {
-Note that all the cmd_[a-zA-Z] subroutines require the command name, a line
-number, and C<$dbline> (the current line) as arguments.
+ # Couldn't open it.
+ DB::_db_warn("Can't execute '$sourced_fn': $!\n");
+ }
+ next CMD;
+ }
-Support functions in this section which have multiple modes of failure C<die>
-on error; the rest simply return a false value.
+ return;
+}
-The user-interface functions (all of the C<cmd_*> functions) just output
-error messages.
+sub _handle_enable_disable_commands {
+ my $self = shift;
-=head2 C<%set>
+ my $which_cmd = $self->cmd_verb;
+ my $position = $self->cmd_args;
-The C<%set> hash defines the mapping from command letter to subroutine
-name suffix.
+ if ($position !~ /\s/) {
+ my ($fn, $line_num);
+ if ($position =~ m{\A\d+\z})
+ {
+ $fn = $DB::filename;
+ $line_num = $position;
+ }
+ elsif (my ($new_fn, $new_line_num)
+ = $position =~ m{\A(.*):(\d+)\z}) {
+ ($fn, $line_num) = ($new_fn, $new_line_num);
+ }
+ else
+ {
+ DB::_db_warn("Wrong spec for enable/disable argument.\n");
+ }
-C<%set> is a two-level hash, indexed by set name and then by command name.
-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>.
+ if (defined($fn)) {
+ if (DB::_has_breakpoint_data_ref($fn, $line_num)) {
+ DB::_set_breakpoint_enabled_status($fn, $line_num,
+ ($which_cmd eq 'enable' ? 1 : '')
+ );
+ }
+ else {
+ DB::_db_warn("No breakpoint set at ${fn}:${line_num}\n");
+ }
+ }
-=cut
+ next CMD;
+ }
-### The API section
+ return;
+}
-my %set = ( #
- 'pre580' => {
- 'a' => 'pre580_a',
- 'A' => 'pre580_null',
- 'b' => 'pre580_b',
- 'B' => 'pre580_null',
- 'd' => 'pre580_null',
- 'D' => 'pre580_D',
- 'h' => 'pre580_h',
- 'M' => 'pre580_null',
- 'O' => 'o',
- 'o' => 'pre580_null',
- 'v' => 'M',
- 'w' => 'v',
- 'W' => 'pre580_W',
- },
- 'pre590' => {
- '<' => 'pre590_prepost',
- '<<' => 'pre590_prepost',
- '>' => 'pre590_prepost',
- '>>' => 'pre590_prepost',
- '{' => 'pre590_prepost',
- '{{' => 'pre590_prepost',
- },
-);
+sub _handle_save_command {
+ my $self = shift;
-my %breakpoints_data;
+ if (my $new_fn = $self->cmd_args) {
+ my $filename = $new_fn || '.perl5dbrc'; # default?
+ if ( open my $fh, '>', $filename ) {
-sub _has_breakpoint_data_ref {
- my ($filename, $line) = @_;
+ # chomp to remove extraneous newlines from source'd files
+ chomp( my @truelist =
+ map { m/\A\s*(save|source)/ ? "#$_" : $_ }
+ @truehist );
+ print {$fh} join( "\n", @truelist );
+ print "commands saved in $filename\n";
+ }
+ else {
+ DB::_db_warn("Can't save debugger commands in '$new_fn': $!\n");
+ }
+ next CMD;
+ }
- return (
- exists( $breakpoints_data{$filename} )
- and
- exists( $breakpoints_data{$filename}{$line} )
- );
+ return;
}
-sub _get_breakpoint_data_ref {
- my ($filename, $line) = @_;
+sub _n_or_s_and_arg_commands_generic {
+ my ($self, $letter, $new_val) = @_;
- return ($breakpoints_data{$filename}{$line} ||= +{});
+ # s - single-step. Remember the last command was 's'.
+ if ($DB::cmd =~ s#\A\Q$letter\E\s#\$DB::single = $new_val;\n#) {
+ $laststep = $letter;
+ }
+
+ return;
}
-sub _delete_breakpoint_data_ref {
- my ($filename, $line) = @_;
+sub _handle_sh_command {
+ my $self = shift;
- delete($breakpoints_data{$filename}{$line});
- if (! scalar(keys( %{$breakpoints_data{$filename}} )) ) {
- delete($breakpoints_data{$filename});
+ # $sh$sh - run a shell command (if it's all ASCII).
+ # Can't run shell commands with Unicode in the debugger, hmm.
+ my $my_cmd = $DB::cmd;
+ if ($my_cmd =~ m#\A$sh#gms) {
+
+ 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::_db_system( $ENV{SHELL} || "/bin/sh" );
+ next CMD;
+ }
+ elsif ($my_cmd =~ m#\G$sh\s*(.*)#cgms) {
+ # System it.
+ DB::_db_system($1);
+ next CMD;
+ }
+ elsif ($my_cmd =~ m#\G\s*(.*)#cgms) {
+ DB::_db_system( $ENV{SHELL} || "/bin/sh", "-c", $1 );
+ next CMD;
+ }
}
-
- return;
}
-sub _set_breakpoint_enabled_status {
- my ($filename, $line, $status) = @_;
+sub _handle_x_command {
+ my $self = shift;
- _get_breakpoint_data_ref($filename, $line)->{'enabled'} =
- ($status ? 1 : '')
- ;
+ if ($DB::cmd =~ s#\Ax\b# #) { # Remainder gets done by DB::eval()
+ $onetimeDump = 'dump'; # main::dumpvar shows the output
+
+ # handle special "x 3 blah" syntax XXX propagate
+ # doc back to special variables.
+ if ( $DB::cmd =~ s#\A\s*(\d+)(?=\s)# #) {
+ $onetimedumpDepth = $1;
+ }
+ }
return;
}
-sub _enable_breakpoint_temp_enabled_status {
- my ($filename, $line) = @_;
+sub _handle_q_command {
+ my $self = shift;
- _get_breakpoint_data_ref($filename, $line)->{'temp_enabled'} = 1;
+ if ($self->_is_full('q')) {
+ $fall_off_end = 1;
+ DB::clean_ENV();
+ exit $?;
+ }
return;
}
-sub _cancel_breakpoint_temp_enabled_status {
- my ($filename, $line) = @_;
+sub _handle_cmd_wrapper_commands {
+ my $self = shift;
- my $ref = _get_breakpoint_data_ref($filename, $line);
+ DB::cmd_wrapper( $self->cmd_verb, $self->cmd_args, $line );
+ next CMD;
+}
- delete ($ref->{'temp_enabled'});
+sub _handle_special_char_cmd_wrapper_commands {
+ my $self = shift;
- if (! %$ref) {
- _delete_breakpoint_data_ref($filename, $line);
+ # 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;
}
-sub _is_breakpoint_enabled {
- my ($filename, $line) = @_;
+} ## end DB::Obj
- my $data_ref = _get_breakpoint_data_ref($filename, $line);
- return ($data_ref->{'enabled'} || $data_ref->{'temp_enabled'});
-}
+package DB;
-=head2 C<cmd_wrapper()> (API)
+# The following code may be executed now:
+# BEGIN {warn 4}
-C<cmd_wrapper()> allows the debugger to switch command sets
-depending on the value of the C<CommandSet> option.
+=head2 sub
-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
-aren't found, the 5.8.0 equivalent is called (if there is one).
+C<sub> is called whenever a subroutine call happens in the program being
+debugged. The variable C<$DB::sub> contains the name of the subroutine
+being called.
-This code uses symbolic references.
+The core function of this subroutine is to actually call the sub in the proper
+context, capturing its output. This of course causes C<DB::DB> to get called
+again, repeating until the subroutine ends and returns control to C<DB::sub>
+again. Once control returns, C<DB::sub> figures out whether or not to dump the
+return value, and returns its captured copy of the return value as its own
+return value. The value then feeds back into the program being debugged as if
+C<DB::sub> hadn't been there at all.
-=cut
+C<sub> does all the work of printing the subroutine entry and exit messages
+enabled by setting C<$frame>. It notes what sub the autoloader got called for,
+and also prints the return value if needed (for the C<r> command and if
+the 16 bit is set in C<$frame>).
-sub cmd_wrapper {
- my $cmd = shift;
- my $line = shift;
- my $dblineno = shift;
+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 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.
- # Assemble the command subroutine's name by looking up the
- # command set and command name in %set. If we can't find it,
- # default to the older version of the command.
- my $call = 'cmd_'
- . ( $set{$CommandSet}{$cmd}
- || ( $cmd =~ /\A[<>{]+/o ? 'prepost' : $cmd ) );
+=head3 C<caller()> support
- # Call the command subroutine, call it by name.
- return __PACKAGE__->can($call)->( $cmd, $line, $dblineno );
-} ## end sub cmd_wrapper
+If C<caller()> is called from the package C<DB>, it provides some
+additional data, in the following order:
-=head3 C<cmd_a> (command)
+=over 4
-The C<a> command handles pre-execution actions. These are associated with a
-particular line, so they're stored in C<%dbline>. We default to the current
-line if none is specified.
+=item * C<$package>
-=cut
+The package name the sub was in
-sub cmd_a {
- my $cmd = shift;
- my $line = shift || ''; # [.|line] expr
- my $dbline = shift;
+=item * C<$filename>
- # If it's dot (here), or not all digits, use the current line.
- $line =~ s/\A\./$dbline/;
+The filename it was defined in
- # Should be a line number followed by an expression.
- if ( my ($lineno, $expr) = $line =~ /^\s*(\d*)\s*(\S.+)/ ) {
+=item * C<$line>
- if (! length($lineno)) {
- $lineno = $dbline;
- }
+The line number it was defined on
- # If we have an expression ...
- if ( length $expr ) {
+=item * C<$subroutine>
- # ... but the line isn't breakable, complain.
- if ( $dbline[$lineno] == 0 ) {
- print $OUT
- "Line $lineno($dbline[$lineno]) does not have an action?\n";
- }
- else {
+The subroutine name; C<(eval)> if an C<eval>().
- # It's executable. Record that the line has an action.
- $had_breakpoints{$filename} |= 2;
+=item * C<$hasargs>
- # Remove any action, temp breakpoint, etc.
- $dbline{$lineno} =~ s/\0[^\0]*//;
+1 if it has arguments, 0 if not
- # Add the action to the line.
- $dbline{$lineno} .= "\0" . action($expr);
+=item * C<$wantarray>
- _set_breakpoint_enabled_status($filename, $lineno, 1);
- }
- } ## end if (length $expr)
- } ## end if ($line =~ /^\s*(\d*)\s*(\S.+)/)
- else {
+1 if array context, 0 if scalar context
- # Syntax wrong.
- print $OUT
- "Adding an action requires an optional lineno and an expression\n"
- ; # hint
- }
-} ## end sub cmd_a
+=item * C<$evaltext>
-=head3 C<cmd_A> (command)
+The C<eval>() text, if any (undefined for C<eval BLOCK>)
-Delete actions. Similar to above, except the delete code is in a separate
-subroutine, C<delete_action>.
+=item * C<$is_require>
-=cut
+frame was created by a C<use> or C<require> statement
-sub cmd_A {
- my $cmd = shift;
- my $line = shift || '';
- my $dbline = shift;
+=item * C<$hints>
- # Dot is this line.
- $line =~ s/^\./$dbline/;
+pragma information; subject to change between versions
- # Call delete_action with a null param to delete them all.
- # The '1' forces the eval to be true. It'll be false only
- # if delete_action blows up for some reason, in which case
- # we print $@ and get out.
- if ( $line eq '*' ) {
- if (! eval { _delete_all_actions(); 1 }) {
- print {$OUT} $@;
- return;
- }
- }
+=item * C<$bitmask>
- # There's a real line number. Pass it to delete_action.
- # Error trapping is as above.
- elsif ( $line =~ /^(\S.*)/ ) {
- if (! eval { delete_action($1); 1 }) {
- print {$OUT} $@;
- return;
- }
- }
+pragma information; subject to change between versions
- # Swing and a miss. Bad syntax.
- else {
- print $OUT
- "Deleting an action requires a line number, or '*' for all\n" ; # hint
- }
-} ## end sub cmd_A
+=item * C<@DB::args>
-=head3 C<delete_action> (API)
+arguments with which the subroutine was invoked
-C<delete_action> accepts either a line number or C<undef>. If a line number
-is specified, we check for the line being executable (if it's not, it
-couldn't have had an action). If it is, we just take the action off (this
-will get any kind of an action, including breakpoints).
+=back
=cut
-sub _remove_action_from_dbline {
- my $i = shift;
+use vars qw($deep);
- $dbline{$i} =~ s/\0[^\0]*//; # \^a
- delete $dbline{$i} if $dbline{$i} eq '';
+# We need to fully qualify the name ("DB::sub") to make "use strict;"
+# happy. -- Shlomi Fish
+
+sub _indent_print_line_info {
+ my ($offset, $str) = @_;
+
+ print_lineinfo( ' ' x ($stack_depth - $offset), $str);
return;
}
-sub _delete_all_actions {
- print {$OUT} "Deleting all actions...\n";
+sub _print_frame_message {
+ my ($al) = @_;
- for my $file ( keys %had_breakpoints ) {
- local *dbline = $main::{ '_<' . $file };
- $max = $#dbline;
- my $was;
- for my $i (1 .. $max) {
- if ( defined $dbline{$i} ) {
- _remove_action_from_dbline($i);
- }
+ 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 {
+ my ( $al, $ret, @ret ) = "";
+
+ # 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
+
+ {
+ # lock ourselves under threads
+ # While lock() permits recursive locks, there's two cases where it's bad
+ # that we keep a hold on the lock while we call the sub:
+ # - during cloning, Package::CLONE might be called in the context of the new
+ # thread, which will deadlock if we hold the lock across the threads::new call
+ # - for any function that waits any significant time
+ # This also deadlocks if the parent thread joins(), since holding the lock
+ # will prevent any child threads passing this point.
+ # So release the lock for the function call.
+ 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).
+ if ($sub eq 'threads::new' && $ENV{PERL5DB_THREADED}) {
+ print "creating new thread\n";
}
- unless ( $had_breakpoints{$file} &= ~2 ) {
- delete $had_breakpoints{$file};
+ # 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' ) {
+ no strict 'refs';
+ $al = " for $$sub" if defined $$sub;
}
- }
- return;
-}
+ # Expand @stack.
+ $#stack = $stack_depth;
-sub delete_action {
- my $i = shift;
+ # Save current single-step setting.
+ $stack[-1] = $single;
- if ( defined($i) ) {
- # Can there be one?
- die "Line $i has no action .\n" if $dbline[$i] == 0;
+ # Turn off all flags except single-stepping.
+ $single &= 1;
- # Nuke whatever's there.
- _remove_action_from_dbline($i);
+ # 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 ...
+
+ _print_frame_message($al);
+ }
+
+ # Determine the sub's return type, and capture appropriately.
+ if (wantarray) {
+
+ # Called in array context. call sub and capture output.
+ # DB::DB will recursively get control again if appropriate; we'll come
+ # back here when the sub is finished.
+ no strict 'refs';
+ @ret = &$sub;
+ }
+ elsif ( defined wantarray ) {
+ no strict 'refs';
+ # Save the value if it's wanted at all.
+ $ret = &$sub;
}
else {
- _delete_all_actions();
+ no strict 'refs';
+ # Void return, explicitly.
+ &$sub;
+ undef $ret;
}
-}
-=head3 C<cmd_b> (command)
+ {
+ lock($DBGR);
-Set breakpoints. Since breakpoints can be set in so many places, in so many
-ways, conditionally or not, the breakpoint code is kind of complex. Mostly,
-we try to parse the command type, and then shuttle it off to an appropriate
-subroutine to actually do the work of setting the breakpoint in the right
-place.
+ # Pop the single-step value back off the stack.
+ $single |= $stack[ $stack_depth-- ];
-=cut
+ if ($frame & 2) {
+ if ($frame & 4) { # Extended exit message
+ _indent_print_line_info(0, "out ");
+ print_trace( $LINEINFO, -1, 1, 1, "$sub$al" );
+ }
+ else {
+ _indent_print_line_info(0, "exited $sub$al\n" );
+ }
+ }
-sub cmd_b {
- my $cmd = shift;
- my $line = shift; # [.|line] [cond]
- my $dbline = shift;
+ if (wantarray) {
+ # Print the return info if we need to.
+ if ( $doret eq $stack_depth or $frame & 16 ) {
- my $default_cond = sub {
- my $cond = shift;
- return length($cond) ? $cond : '1';
- };
+ # Turn off output record separator.
+ local $\ = '';
+ my $fh = ( $doret eq $stack_depth ? $OUT : $LINEINFO );
- # Make . the current line number if it's there..
- $line =~ s/^\.(\s|\z)/$dbline$1/;
+ # Indent if we're printing because of $frame tracing.
+ if ($frame & 16)
+ {
+ print {$fh} ' ' x $stack_depth;
+ }
- # No line number, no condition. Simple break on current line.
- if ( $line =~ /^\s*$/ ) {
- cmd_b_line( $dbline, 1 );
- }
+ # Print the return value.
+ print {$fh} "list context return from $sub:\n";
+ dumpit( $fh, \@ret );
- # Break on load for a file.
- elsif ( my ($file) = $line =~ /^load\b\s*(.*)/ ) {
- $file =~ s/\s+\z//;
- cmd_b_load($file);
+ # And don't print it again.
+ $doret = -2;
+ } ## end if ($doret eq $stack_depth...
+ # And we have to return the return value now.
+ @ret;
+ } ## end if (wantarray)
+ # Scalar context.
+ else {
+ # If we are supposed to show the return value... same as before.
+ if ( $doret eq $stack_depth or $frame & 16 and defined wantarray ) {
+ local $\ = '';
+ my $fh = ( $doret eq $stack_depth ? $OUT : $LINEINFO );
+ print $fh ( ' ' x $stack_depth ) if $frame & 16;
+ print $fh (
+ defined wantarray
+ ? "scalar context return from $sub: "
+ : "void context return from $sub\n"
+ );
+ dumpit( $fh, $ret ) if defined wantarray;
+ $doret = -2;
+ } ## end if ($doret eq $stack_depth...
+
+ # Return the appropriate scalar value.
+ $ret;
+ } ## end else [ if (wantarray)
}
+} ## end sub _sub
- # b compile|postpone <some sub> [<condition>]
- # The interpreter actually traps this one for us; we just put the
- # necessary condition in the %postponed hash.
- elsif ( my ($action, $subname, $cond)
- = $line =~ /^(postpone|compile)\b\s*([':A-Za-z_][':\w]*)\s*(.*)/ ) {
+sub lsub : lvalue {
- # De-Perl4-ify the name - ' separators to ::.
- $subname =~ s/'/::/g;
+ # 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
- # Qualify it into the current package unless it's already qualified.
- $subname = "${package}::" . $subname unless $subname =~ /::/;
+ # Expand @stack.
+ $#stack = $stack_depth;
- # Add main if it starts with ::.
- $subname = "main" . $subname if substr( $subname, 0, 2 ) eq "::";
+ # Save current single-step setting.
+ $stack[-1] = $single;
- # Save the break type for this sub.
- $postponed{$subname} = (($action eq 'postpone')
- ? ( "break +0 if " . $default_cond->($cond) )
- : "compile");
- } ## end elsif ($line =~ ...
- # b <filename>:<line> [<condition>]
- elsif (my ($filename, $line_num, $cond)
- = $line =~ /\A(\S+[^:]):(\d+)\s*(.*)/ms) {
- cmd_b_filename_line(
- $filename,
- $line_num,
- (length($cond) ? $cond : '1'),
- );
- }
- # b <sub name> [<condition>]
- elsif ( my ($new_subname, $new_cond) =
- $line =~ /^([':A-Za-z_][':\w]*(?:\[.*\])?)\s*(.*)/ ) {
+ # Turn off all flags except single-stepping.
+ # Use local so the single-step value is popped back off the
+ # stack for us.
+ local $single = $single & 1;
- #
- $subname = $new_subname;
- cmd_b_sub( $subname, $default_cond->($new_cond) );
- }
+ no strict 'refs';
+ {
+ # lock ourselves under threads
+ lock($DBGR);
- # b <line> [<condition>].
- elsif ( my ($line_n, $cond) = $line =~ /^(\d*)\s*(.*)/ ) {
+ # 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";
+ }
- # Capture the line. If none, it's the current line.
- $line = $line_n || $dbline;
+ # 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";
+ }
- # Break on line.
- cmd_b_line( $line, $default_cond->($cond) );
- }
+ # 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;
- # Line didn't make sense.
- else {
- print "confused by line($line)?\n";
+ # If frame messages are on ...
+ _print_frame_message($al);
}
- return;
-} ## end sub cmd_b
+ # call the original lvalue sub.
+ &$sub;
+}
-=head3 C<break_on_load> (API)
+# Abstracting common code from multiple places elsewhere:
+sub depth_print_lineinfo {
+ my $always_print = shift;
-We want to break when this file is loaded. Mark this file in the
-C<%break_on_load> hash, and note that it has a breakpoint in
-C<%had_breakpoints>.
+ print_lineinfo( @_ ) if ($always_print or $stack_depth < $trace_to_depth);
+}
-=cut
+=head1 EXTENDED COMMAND HANDLING AND THE COMMAND API
-sub break_on_load {
- my $file = shift;
- $break_on_load{$file} = 1;
- $had_breakpoints{$file} |= 1;
-}
+In Perl 5.8.0, there was a major realignment of the commands and what they did,
+Most of the changes were to systematize the command structure and to eliminate
+commands that threw away user input without checking.
-=head3 C<report_break_on_load> (API)
+The following sections describe the code added to make it easy to support
+multiple command sets with conflicting command names. This section is a start
+at unifying all command processing to make it simpler to develop commands.
-Gives us an array of filenames that are set to break on load. Note that
-only files with break-on-load are in here, so simply showing the keys
-suffices.
+Note that all the cmd_[a-zA-Z] subroutines require the command name, a line
+number, and C<$dbline> (the current line) as arguments.
+
+Support functions in this section which have multiple modes of failure C<die>
+on error; the rest simply return a false value.
+
+The user-interface functions (all of the C<cmd_*> functions) just output
+error messages.
+
+=head2 C<%set>
+
+The C<%set> hash defines the mapping from command letter to subroutine
+name suffix.
+
+C<%set> is a two-level hash, indexed by set name and then by command name.
+Note that trying to set the CommandSet to C<foobar> simply results in the
+5.8.0 command set being used, since there's no top-level entry for C<foobar>.
=cut
-sub report_break_on_load {
- sort keys %break_on_load;
+### The API section
+
+my %set = ( #
+ 'pre580' => {
+ 'a' => 'pre580_a',
+ 'A' => 'pre580_null',
+ 'b' => 'pre580_b',
+ 'B' => 'pre580_null',
+ 'd' => 'pre580_null',
+ 'D' => 'pre580_D',
+ 'h' => 'pre580_h',
+ 'M' => 'pre580_null',
+ 'O' => 'o',
+ 'o' => 'pre580_null',
+ 'v' => 'M',
+ 'w' => 'v',
+ 'W' => 'pre580_W',
+ },
+ 'pre590' => {
+ '<' => 'pre590_prepost',
+ '<<' => 'pre590_prepost',
+ '>' => 'pre590_prepost',
+ '>>' => 'pre590_prepost',
+ '{' => 'pre590_prepost',
+ '{{' => 'pre590_prepost',
+ },
+);
+
+my %breakpoints_data;
+
+sub _has_breakpoint_data_ref {
+ my ($filename, $line) = @_;
+
+ return (
+ exists( $breakpoints_data{$filename} )
+ and
+ exists( $breakpoints_data{$filename}{$line} )
+ );
}
-=head3 C<cmd_b_load> (command)
+sub _get_breakpoint_data_ref {
+ my ($filename, $line) = @_;
-We take the file passed in and try to find it in C<%INC> (which maps modules
-to files they came from). We mark those files for break-on-load via
-C<break_on_load> and then report that it was done.
+ return ($breakpoints_data{$filename}{$line} ||= +{});
+}
-=cut
+sub _delete_breakpoint_data_ref {
+ my ($filename, $line) = @_;
-sub cmd_b_load {
- my $file = shift;
- my @files;
+ delete($breakpoints_data{$filename}{$line});
+ if (! scalar(keys( %{$breakpoints_data{$filename}} )) ) {
+ delete($breakpoints_data{$filename});
+ }
- # This is a block because that way we can use a redo inside it
- # even without there being any looping structure at all outside it.
- {
+ return;
+}
- # Save short name and full path if found.
- push @files, $file;
- push @files, $::INC{$file} if $::INC{$file};
+sub _set_breakpoint_enabled_status {
+ my ($filename, $line, $status) = @_;
+
+ _get_breakpoint_data_ref($filename, $line)->{'enabled'} =
+ ($status ? 1 : '')
+ ;
+
+ return;
+}
+
+sub _enable_breakpoint_temp_enabled_status {
+ my ($filename, $line) = @_;
+
+ _get_breakpoint_data_ref($filename, $line)->{'temp_enabled'} = 1;
- # Tack on .pm and do it again unless there was a '.' in the name
- # already.
- $file .= '.pm', redo unless $file =~ /\./;
- }
+ return;
+}
- # Do the real work here.
- break_on_load($_) for @files;
+sub _cancel_breakpoint_temp_enabled_status {
+ my ($filename, $line) = @_;
- # All the files that have break-on-load breakpoints.
- @files = report_break_on_load;
+ my $ref = _get_breakpoint_data_ref($filename, $line);
- # Normalize for the purposes of our printing this.
- local $\ = '';
- local $" = ' ';
- print $OUT "Will stop on load of '@files'.\n";
-} ## end sub cmd_b_load
+ delete ($ref->{'temp_enabled'});
-=head3 C<$filename_error> (API package global)
+ if (! %$ref) {
+ _delete_breakpoint_data_ref($filename, $line);
+ }
-Several of the functions we need to implement in the API need to work both
-on the current file and on other files. We don't want to duplicate code, so
-C<$filename_error> is used to contain the name of the file that's being
-worked on (if it's not the current one).
+ return;
+}
-We can now build functions in pairs: the basic function works on the current
-file, and uses C<$filename_error> as part of its error message. Since this is
-initialized to C<"">, no filename will appear when we are working on the
-current file.
+sub _is_breakpoint_enabled {
+ my ($filename, $line) = @_;
-The second function is a wrapper which does the following:
+ my $data_ref = _get_breakpoint_data_ref($filename, $line);
+ return ($data_ref->{'enabled'} || $data_ref->{'temp_enabled'});
+}
-=over 4
+=head2 C<cmd_wrapper()> (API)
-=item *
+C<cmd_wrapper()> allows the debugger to switch command sets
+depending on the value of the C<CommandSet> option.
-Localizes C<$filename_error> and sets it to the name of the file to be processed.
+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
+aren't found, the 5.8.0 equivalent is called (if there is one).
-=item *
+This code uses symbolic references.
-Localizes the C<*dbline> glob and reassigns it to point to the file we want to process.
+=cut
-=item *
+sub cmd_wrapper {
+ my $cmd = shift;
+ my $line = shift;
+ my $dblineno = shift;
-Calls the first function.
+ # Assemble the command subroutine's name by looking up the
+ # command set and command name in %set. If we can't find it,
+ # default to the older version of the command.
+ my $call = 'cmd_'
+ . ( $set{$CommandSet}{$cmd}
+ || ( $cmd =~ /\A[<>{]+/o ? 'prepost' : $cmd ) );
-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.
+ # Call the command subroutine, call it by name.
+ return __PACKAGE__->can($call)->( $cmd, $line, $dblineno );
+} ## end sub cmd_wrapper
-See the comments in C<breakable_line> and C<breakable_line_in_file> for more
-details.
+=head3 C<cmd_a> (command)
-=back
+The C<a> command handles pre-execution actions. These are associated with a
+particular line, so they're stored in C<%dbline>. We default to the current
+line if none is specified.
=cut
-use vars qw($filename_error);
-$filename_error = '';
+sub cmd_a {
+ my $cmd = shift;
+ my $line = shift || ''; # [.|line] expr
+ my $dbline = shift;
-=head3 breakable_line(from, to) (API)
+ # If it's dot (here), or not all digits, use the current line.
+ $line =~ s/\A\./$dbline/;
-The subroutine decides whether or not a line in the current file is breakable.
-It walks through C<@dbline> within the range of lines specified, looking for
-the first line that is breakable.
+ # Should be a line number followed by an expression.
+ if ( my ($lineno, $expr) = $line =~ /^\s*(\d*)\s*(\S.+)/ ) {
-If C<$to> is greater than C<$from>, the search moves forwards, finding the
-first line I<after> C<$to> that's breakable, if there is one.
+ if (! length($lineno)) {
+ $lineno = $dbline;
+ }
-If C<$from> is greater than C<$to>, the search goes I<backwards>, finding the
-first line I<before> C<$to> that's breakable, if there is one.
+ # If we have an expression ...
+ if ( length $expr ) {
-=cut
+ # ... but the line isn't breakable, complain.
+ if ( $dbline[$lineno] == 0 ) {
+ print $OUT
+ "Line $lineno($dbline[$lineno]) does not have an action?\n";
+ }
+ else {
-sub breakable_line {
+ # It's executable. Record that the line has an action.
+ $had_breakpoints{$filename} |= 2;
- my ( $from, $to ) = @_;
+ # Remove any action, temp breakpoint, etc.
+ $dbline{$lineno} =~ s/\0[^\0]*//;
- # $i is the start point. (Where are the FORTRAN programs of yesteryear?)
- my $i = $from;
+ # Add the action to the line.
+ $dbline{$lineno} .= "\0" . action($expr);
- # If there are at least 2 arguments, we're trying to search a range.
- if ( @_ >= 2 ) {
+ _set_breakpoint_enabled_status($filename, $lineno, 1);
+ }
+ } ## end if (length $expr)
+ } ## end if ($line =~ /^\s*(\d*)\s*(\S.+)/)
+ else {
- # $delta is positive for a forward search, negative for a backward one.
- my $delta = $from < $to ? +1 : -1;
+ # Syntax wrong.
+ print $OUT
+ "Adding an action requires an optional lineno and an expression\n"
+ ; # hint
+ }
+} ## end sub cmd_a
- # Keep us from running off the ends of the file.
- my $limit = $delta > 0 ? $#dbline : 1;
+=head3 C<cmd_A> (command)
- # Clever test. If you're a mathematician, it's obvious why this
- # test works. If not:
- # If $delta is positive (going forward), $limit will be $#dbline.
- # If $to is less than $limit, ($limit - $to) will be positive, times
- # $delta of 1 (positive), so the result is > 0 and we should use $to
- # as the stopping point.
- #
- # If $to is greater than $limit, ($limit - $to) is negative,
- # times $delta of 1 (positive), so the result is < 0 and we should
- # use $limit ($#dbline) as the stopping point.
- #
- # If $delta is negative (going backward), $limit will be 1.
- # If $to is zero, ($limit - $to) will be 1, times $delta of -1
- # (negative) so the result is > 0, and we use $to as the stopping
- # point.
- #
- # If $to is less than zero, ($limit - $to) will be positive,
- # times $delta of -1 (negative), so the result is not > 0, and
- # we use $limit (1) as the stopping point.
- #
- # If $to is 1, ($limit - $to) will zero, times $delta of -1
- # (negative), still giving zero; the result is not > 0, and
- # we use $limit (1) as the stopping point.
- #
- # if $to is >1, ($limit - $to) will be negative, times $delta of -1
- # (negative), giving a positive (>0) value, so we'll set $limit to
- # $to.
+Delete actions. Similar to above, except the delete code is in a separate
+subroutine, C<delete_action>.
- $limit = $to if ( $limit - $to ) * $delta > 0;
+=cut
- # The real search loop.
- # $i starts at $from (the point we want to start searching from).
- # We move through @dbline in the appropriate direction (determined
- # by $delta: either -1 (back) or +1 (ahead).
- # We stay in as long as we haven't hit an executable line
- # ($dbline[$i] == 0 means not executable) and we haven't reached
- # the limit yet (test similar to the above).
- $i += $delta while $dbline[$i] == 0 and ( $limit - $i ) * $delta > 0;
+sub cmd_A {
+ my $cmd = shift;
+ my $line = shift || '';
+ my $dbline = shift;
- } ## end if (@_ >= 2)
+ # Dot is this line.
+ $line =~ s/^\./$dbline/;
- # If $i points to a line that is executable, return that.
- return $i unless $dbline[$i] == 0;
+ # Call delete_action with a null param to delete them all.
+ # The '1' forces the eval to be true. It'll be false only
+ # if delete_action blows up for some reason, in which case
+ # we print $@ and get out.
+ if ( $line eq '*' ) {
+ if (! eval { _delete_all_actions(); 1 }) {
+ print {$OUT} $@;
+ return;
+ }
+ }
- # Format the message and print it: no breakable lines in range.
- my ( $pl, $upto ) = ( '', '' );
- ( $pl, $upto ) = ( 's', "..$to" ) if @_ >= 2 and $from != $to;
+ # There's a real line number. Pass it to delete_action.
+ # Error trapping is as above.
+ elsif ( $line =~ /^(\S.*)/ ) {
+ if (! eval { delete_action($1); 1 }) {
+ print {$OUT} $@;
+ return;
+ }
+ }
- # If there's a filename in filename_error, we'll see it.
- # If not, not.
- die "Line$pl $from$upto$filename_error not breakable\n";
-} ## end sub breakable_line
+ # Swing and a miss. Bad syntax.
+ else {
+ print $OUT
+ "Deleting an action requires a line number, or '*' for all\n" ; # hint
+ }
+} ## end sub cmd_A
-=head3 breakable_line_in_filename(file, from, to) (API)
+=head3 C<delete_action> (API)
-Like C<breakable_line>, but look in another file.
+C<delete_action> accepts either a line number or C<undef>. If a line number
+is specified, we check for the line being executable (if it's not, it
+couldn't have had an action). If it is, we just take the action off (this
+will get any kind of an action, including breakpoints).
=cut
-sub breakable_line_in_filename {
+sub _remove_action_from_dbline {
+ my $i = shift;
- # Capture the file name.
- my ($f) = shift;
+ $dbline{$i} =~ s/\0[^\0]*//; # \^a
+ delete $dbline{$i} if $dbline{$i} eq '';
- # Swap the magic line array over there temporarily.
- local *dbline = $main::{ '_<' . $f };
+ return;
+}
+
+sub _delete_all_actions {
+ print {$OUT} "Deleting all actions...\n";
+
+ for my $file ( keys %had_breakpoints ) {
+ local *dbline = $main::{ '_<' . $file };
+ $max = $#dbline;
+ my $was;
+ for my $i (1 .. $max) {
+ if ( defined $dbline{$i} ) {
+ _remove_action_from_dbline($i);
+ }
+ }
+
+ unless ( $had_breakpoints{$file} &= ~2 ) {
+ delete $had_breakpoints{$file};
+ }
+ }
- # If there's an error, it's in this other file.
- local $filename_error = " of '$f'";
+ return;
+}
- # Find the breakable line.
- breakable_line(@_);
+sub delete_action {
+ my $i = shift;
- # *dbline and $filename_error get restored when this block ends.
+ if ( defined($i) ) {
+ # Can there be one?
+ die "Line $i has no action .\n" if $dbline[$i] == 0;
-} ## end sub breakable_line_in_filename
+ # Nuke whatever's there.
+ _remove_action_from_dbline($i);
+ }
+ else {
+ _delete_all_actions();
+ }
+}
-=head3 break_on_line(lineno, [condition]) (API)
+=head3 C<cmd_b> (command)
-Adds a breakpoint with the specified condition (or 1 if no condition was
-specified) to the specified line. Dies if it can't.
+Set breakpoints. Since breakpoints can be set in so many places, in so many
+ways, conditionally or not, the breakpoint code is kind of complex. Mostly,
+we try to parse the command type, and then shuttle it off to an appropriate
+subroutine to actually do the work of setting the breakpoint in the right
+place.
=cut
-sub break_on_line {
- my $i = shift;
- my $cond = @_ ? shift(@_) : 1;
-
- my $inii = $i;
- my $after = '';
- my $pl = '';
-
- # Woops, not a breakable line. $filename_error allows us to say
- # if it was in a different file.
- die "Line $i$filename_error not breakable.\n" if $dbline[$i] == 0;
+sub cmd_b {
+ my $cmd = shift;
+ my $line = shift; # [.|line] [cond]
+ my $dbline = shift;
- # Mark this file as having breakpoints in it.
- $had_breakpoints{$filename} |= 1;
+ my $default_cond = sub {
+ my $cond = shift;
+ return length($cond) ? $cond : '1';
+ };
- # If there is an action or condition here already ...
- if ( $dbline{$i} ) {
+ # Make . the current line number if it's there..
+ $line =~ s/^\.(\s|\z)/$dbline$1/;
- # ... swap this condition for the existing one.
- $dbline{$i} =~ s/^[^\0]*/$cond/;
+ # No line number, no condition. Simple break on current line.
+ if ( $line =~ /^\s*$/ ) {
+ cmd_b_line( $dbline, 1 );
}
- else {
- # Nothing here - just add the condition.
- $dbline{$i} = $cond;
-
- _set_breakpoint_enabled_status($filename, $i, 1);
+ # Break on load for a file.
+ elsif ( my ($file) = $line =~ /^load\b\s*(.*)/ ) {
+ $file =~ s/\s+\z//;
+ cmd_b_load($file);
}
- return;
-} ## end sub break_on_line
+ # b compile|postpone <some sub> [<condition>]
+ # The interpreter actually traps this one for us; we just put the
+ # necessary condition in the %postponed hash.
+ elsif ( my ($action, $subname, $cond)
+ = $line =~ /^(postpone|compile)\b\s*([':A-Za-z_][':\w]*)\s*(.*)/ ) {
-=head3 cmd_b_line(line, [condition]) (command)
+ # De-Perl4-ify the name - ' separators to ::.
+ $subname =~ s/'/::/g;
-Wrapper for C<break_on_line>. Prints the failure message if it
-doesn't work.
+ # Qualify it into the current package unless it's already qualified.
+ $subname = "${package}::" . $subname unless $subname =~ /::/;
-=cut
+ # Add main if it starts with ::.
+ $subname = "main" . $subname if substr( $subname, 0, 2 ) eq "::";
-sub cmd_b_line {
- if (not eval { break_on_line(@_); 1 }) {
- local $\ = '';
- print $OUT $@ and return;
+ # Save the break type for this sub.
+ $postponed{$subname} = (($action eq 'postpone')
+ ? ( "break +0 if " . $default_cond->($cond) )
+ : "compile");
+ } ## end elsif ($line =~ ...
+ # b <filename>:<line> [<condition>]
+ elsif (my ($filename, $line_num, $cond)
+ = $line =~ /\A(\S+[^:]):(\d+)\s*(.*)/ms) {
+ cmd_b_filename_line(
+ $filename,
+ $line_num,
+ (length($cond) ? $cond : '1'),
+ );
}
+ # b <sub name> [<condition>]
+ elsif ( my ($new_subname, $new_cond) =
+ $line =~ /^([':A-Za-z_][':\w]*(?:\[.*\])?)\s*(.*)/ ) {
- return;
-} ## end sub cmd_b_line
+ #
+ $subname = $new_subname;
+ cmd_b_sub( $subname, $default_cond->($new_cond) );
+ }
-=head3 cmd_b_filename_line(line, [condition]) (command)
+ # b <line> [<condition>].
+ elsif ( my ($line_n, $cond) = $line =~ /^(\d*)\s*(.*)/ ) {
-Wrapper for C<break_on_filename_line>. Prints the failure message if it
-doesn't work.
+ # Capture the line. If none, it's the current line.
+ $line = $line_n || $dbline;
-=cut
+ # Break on line.
+ cmd_b_line( $line, $default_cond->($cond) );
+ }
-sub cmd_b_filename_line {
- if (not eval { break_on_filename_line(@_); 1 }) {
- local $\ = '';
- print $OUT $@ and return;
+ # Line didn't make sense.
+ else {
+ print "confused by line($line)?\n";
}
return;
-}
+} ## end sub cmd_b
-=head3 break_on_filename_line(file, line, [condition]) (API)
+=head3 C<break_on_load> (API)
-Switches to the file specified and then calls C<break_on_line> to set
-the breakpoint.
+We want to break when this file is loaded. Mark this file in the
+C<%break_on_load> hash, and note that it has a breakpoint in
+C<%had_breakpoints>.
=cut
-sub break_on_filename_line {
- my $f = shift;
- my $i = shift;
- my $cond = @_ ? shift(@_) : 1;
+sub break_on_load {
+ my $file = shift;
+ $break_on_load{$file} = 1;
+ $had_breakpoints{$file} |= 1;
+}
- # Switch the magical hash temporarily.
- local *dbline = $main::{ '_<' . $f };
+=head3 C<report_break_on_load> (API)
- # Localize the variables that break_on_line uses to make its message.
- local $filename_error = " of '$f'";
- local $filename = $f;
+Gives us an array of filenames that are set to break on load. Note that
+only files with break-on-load are in here, so simply showing the keys
+suffices.
- # Add the breakpoint.
- break_on_line( $i, $cond );
+=cut
- return;
-} ## end sub break_on_filename_line
+sub report_break_on_load {
+ sort keys %break_on_load;
+}
-=head3 break_on_filename_line_range(file, from, to, [condition]) (API)
+=head3 C<cmd_b_load> (command)
-Switch to another file, search the range of lines specified for an
-executable one, and put a breakpoint on the first one you find.
+We take the file passed in and try to find it in C<%INC> (which maps modules
+to files they came from). We mark those files for break-on-load via
+C<break_on_load> and then report that it was done.
=cut
-sub break_on_filename_line_range {
- my $f = shift;
- my $from = shift;
- my $to = shift;
- my $cond = @_ ? shift(@_) : 1;
+sub cmd_b_load {
+ my $file = shift;
+ my @files;
- # Find a breakable line if there is one.
- my $i = breakable_line_in_filename( $f, $from, $to );
+ # This is a block because that way we can use a redo inside it
+ # even without there being any looping structure at all outside it.
+ {
- # Add the breakpoint.
- break_on_filename_line( $f, $i, $cond );
+ # Save short name and full path if found.
+ push @files, $file;
+ push @files, $::INC{$file} if $::INC{$file};
- return;
-} ## end sub break_on_filename_line_range
+ # Tack on .pm and do it again unless there was a '.' in the name
+ # already.
+ $file .= '.pm', redo unless $file =~ /\./;
+ }
-=head3 subroutine_filename_lines(subname, [condition]) (API)
+ # Do the real work here.
+ break_on_load($_) for @files;
-Search for a subroutine within a given file. The condition is ignored.
-Uses C<find_sub> to locate the desired subroutine.
+ # All the files that have break-on-load breakpoints.
+ @files = report_break_on_load;
-=cut
+ # Normalize for the purposes of our printing this.
+ local $\ = '';
+ local $" = ' ';
+ print $OUT "Will stop on load of '@files'.\n";
+} ## end sub cmd_b_load
-sub subroutine_filename_lines {
- my ( $subname ) = @_;
+=head3 C<$filename_error> (API package global)
- # Returned value from find_sub() is fullpathname:startline-endline.
- # The match creates the list (fullpathname, start, end).
- return (find_sub($subname) =~ /^(.*):(\d+)-(\d+)$/);
-} ## end sub subroutine_filename_lines
+Several of the functions we need to implement in the API need to work both
+on the current file and on other files. We don't want to duplicate code, so
+C<$filename_error> is used to contain the name of the file that's being
+worked on (if it's not the current one).
-=head3 break_subroutine(subname) (API)
+We can now build functions in pairs: the basic function works on the current
+file, and uses C<$filename_error> as part of its error message. Since this is
+initialized to C<"">, no filename will appear when we are working on the
+current file.
-Places a break on the first line possible in the specified subroutine. Uses
-C<subroutine_filename_lines> to find the subroutine, and
-C<break_on_filename_line_range> to place the break.
+The second function is a wrapper which does the following:
-=cut
+=over 4
-sub break_subroutine {
- my $subname = shift;
+=item *
- # Get filename, start, and end.
- my ( $file, $s, $e ) = subroutine_filename_lines($subname)
- or die "Subroutine $subname not found.\n";
+Localizes C<$filename_error> and sets it to the name of the file to be processed.
+=item *
- # Null condition changes to '1' (always true).
- my $cond = @_ ? shift(@_) : 1;
+Localizes the C<*dbline> glob and reassigns it to point to the file we want to process.
- # Put a break the first place possible in the range of lines
- # that make up this subroutine.
- break_on_filename_line_range( $file, $s, $e, $cond );
+=item *
- return;
-} ## end sub break_subroutine
+Calls the first function.
-=head3 cmd_b_sub(subname, [condition]) (command)
+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.
-We take the incoming subroutine name and fully-qualify it as best we can.
+See the comments in C<breakable_line> and C<breakable_line_in_file> for more
+details.
-=over 4
+=back
-=item 1. If it's already fully-qualified, leave it alone.
+=cut
-=item 2. Try putting it in the current package.
+use vars qw($filename_error);
+$filename_error = '';
-=item 3. If it's not there, try putting it in CORE::GLOBAL if it exists there.
+=head3 breakable_line(from, to) (API)
-=item 4. If it starts with '::', put it in 'main::'.
+The subroutine decides whether or not a line in the current file is breakable.
+It walks through C<@dbline> within the range of lines specified, looking for
+the first line that is breakable.
-=back
+If C<$to> is greater than C<$from>, the search moves forwards, finding the
+first line I<after> C<$to> that's breakable, if there is one.
-After all this cleanup, we call C<break_subroutine> to try to set the
-breakpoint.
+If C<$from> is greater than C<$to>, the search goes I<backwards>, finding the
+first line I<before> C<$to> that's breakable, if there is one.
=cut
-sub cmd_b_sub {
- my $subname = shift;
- my $cond = @_ ? shift : 1;
+sub breakable_line {
- # If the subname isn't a code reference, qualify it so that
- # break_subroutine() will work right.
- if ( ref($subname) ne 'CODE' ) {
+ my ( $from, $to ) = @_;
- # Not Perl 4.
- $subname =~ s/'/::/g;
- my $s = $subname;
+ # $i is the start point. (Where are the FORTRAN programs of yesteryear?)
+ my $i = $from;
- # Put it in this package unless it's already qualified.
- if ($subname !~ /::/)
- {
- $subname = $package . '::' . $subname;
- };
+ # If there are at least 2 arguments, we're trying to search a range.
+ if ( @_ >= 2 ) {
- # 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.
- my $core_name = "CORE::GLOBAL::$s";
- if ((!defined(&$subname))
- and ($s !~ /::/)
- and (defined &{$core_name}))
- {
- $subname = $core_name;
- }
+ # $delta is positive for a forward search, negative for a backward one.
+ my $delta = $from < $to ? +1 : -1;
- # Put it in package 'main' if it has a leading ::.
- if ($subname =~ /\A::/)
- {
- $subname = "main" . $subname;
- }
- } ## end if ( ref($subname) ne 'CODE' ) {
+ # Keep us from running off the ends of the file.
+ my $limit = $delta > 0 ? $#dbline : 1;
- # Try to set the breakpoint.
- if (not eval { break_subroutine( $subname, $cond ); 1 }) {
- local $\ = '';
- print {$OUT} $@;
- return;
- }
+ # Clever test. If you're a mathematician, it's obvious why this
+ # test works. If not:
+ # If $delta is positive (going forward), $limit will be $#dbline.
+ # If $to is less than $limit, ($limit - $to) will be positive, times
+ # $delta of 1 (positive), so the result is > 0 and we should use $to
+ # as the stopping point.
+ #
+ # If $to is greater than $limit, ($limit - $to) is negative,
+ # times $delta of 1 (positive), so the result is < 0 and we should
+ # use $limit ($#dbline) as the stopping point.
+ #
+ # If $delta is negative (going backward), $limit will be 1.
+ # If $to is zero, ($limit - $to) will be 1, times $delta of -1
+ # (negative) so the result is > 0, and we use $to as the stopping
+ # point.
+ #
+ # If $to is less than zero, ($limit - $to) will be positive,
+ # times $delta of -1 (negative), so the result is not > 0, and
+ # we use $limit (1) as the stopping point.
+ #
+ # If $to is 1, ($limit - $to) will zero, times $delta of -1
+ # (negative), still giving zero; the result is not > 0, and
+ # we use $limit (1) as the stopping point.
+ #
+ # if $to is >1, ($limit - $to) will be negative, times $delta of -1
+ # (negative), giving a positive (>0) value, so we'll set $limit to
+ # $to.
- return;
-} ## end sub cmd_b_sub
+ $limit = $to if ( $limit - $to ) * $delta > 0;
-=head3 C<cmd_B> - delete breakpoint(s) (command)
+ # The real search loop.
+ # $i starts at $from (the point we want to start searching from).
+ # We move through @dbline in the appropriate direction (determined
+ # by $delta: either -1 (back) or +1 (ahead).
+ # We stay in as long as we haven't hit an executable line
+ # ($dbline[$i] == 0 means not executable) and we haven't reached
+ # the limit yet (test similar to the above).
+ $i += $delta while $dbline[$i] == 0 and ( $limit - $i ) * $delta > 0;
-The command mostly parses the command line and tries to turn the argument
-into a line spec. If it can't, it uses the current line. It then calls
-C<delete_breakpoint> to actually do the work.
+ } ## end if (@_ >= 2)
-If C<*> is specified, C<cmd_B> calls C<delete_breakpoint> with no arguments,
-thereby deleting all the breakpoints.
+ # If $i points to a line that is executable, return that.
+ return $i unless $dbline[$i] == 0;
-=cut
+ # Format the message and print it: no breakable lines in range.
+ my ( $pl, $upto ) = ( '', '' );
+ ( $pl, $upto ) = ( 's', "..$to" ) if @_ >= 2 and $from != $to;
-sub cmd_B {
- my $cmd = shift;
+ # If there's a filename in filename_error, we'll see it.
+ # If not, not.
+ die "Line$pl $from$upto$filename_error not breakable\n";
+} ## end sub breakable_line
- # No line spec? Use dbline.
- # If there is one, use it if it's non-zero, or wipe it out if it is.
- my $line = ( $_[0] =~ /\A\./ ) ? $dbline : (shift || '');
- my $dbline = shift;
+=head3 breakable_line_in_filename(file, from, to) (API)
- # If the line was dot, make the line the current one.
- $line =~ s/^\./$dbline/;
+Like C<breakable_line>, but look in another file.
- # If it's * we're deleting all the breakpoints.
- if ( $line eq '*' ) {
- if (not eval { delete_breakpoint(); 1 }) {
- print {$OUT} $@;
- }
- }
+=cut
- # If there is a line spec, delete the breakpoint on that line.
- elsif ( $line =~ /\A(\S.*)/ ) {
- if (not eval { delete_breakpoint( $line || $dbline ); 1 }) {
- local $\ = '';
- print {$OUT} $@;
- }
- } ## end elsif ($line =~ /^(\S.*)/)
+sub breakable_line_in_filename {
- # No line spec.
- else {
- print {$OUT}
- "Deleting a breakpoint requires a line number, or '*' for all\n"
- ; # hint
- }
+ # Capture the file name.
+ my ($f) = shift;
- return;
-} ## end sub cmd_B
+ # Swap the magic line array over there temporarily.
+ local *dbline = $main::{ '_<' . $f };
-=head3 delete_breakpoint([line]) (API)
+ # If there's an error, it's in this other file.
+ local $filename_error = " of '$f'";
-This actually does the work of deleting either a single breakpoint, or all
-of them.
+ # Find the breakable line.
+ breakable_line(@_);
-For a single line, we look for it in C<@dbline>. If it's nonbreakable, we
-just drop out with a message saying so. If it is, we remove the condition
-part of the 'condition\0action' that says there's a breakpoint here. If,
-after we've done that, there's nothing left, we delete the corresponding
-line in C<%dbline> to signal that no action needs to be taken for this line.
+ # *dbline and $filename_error get restored when this block ends.
-For all breakpoints, we iterate through the keys of C<%had_breakpoints>,
-which lists all currently-loaded files which have breakpoints. We then look
-at each line in each of these files, temporarily switching the C<%dbline>
-and C<@dbline> structures to point to the files in question, and do what
-we did in the single line case: delete the condition in C<@dbline>, and
-delete the key in C<%dbline> if nothing's left.
+} ## end sub breakable_line_in_filename
-We then wholesale delete C<%postponed>, C<%postponed_file>, and
-C<%break_on_load>, because these structures contain breakpoints for files
-and code that haven't been loaded yet. We can just kill these off because there
-are no magical debugger structures associated with them.
+=head3 break_on_line(lineno, [condition]) (API)
+
+Adds a breakpoint with the specified condition (or 1 if no condition was
+specified) to the specified line. Dies if it can't.
=cut
-sub _remove_breakpoint_entry {
- my ($fn, $i) = @_;
+sub break_on_line {
+ my $i = shift;
+ my $cond = @_ ? shift(@_) : 1;
- delete $dbline{$i};
- _delete_breakpoint_data_ref($fn, $i);
+ my $inii = $i;
+ my $after = '';
+ my $pl = '';
- return;
-}
+ # Woops, not a breakable line. $filename_error allows us to say
+ # if it was in a different file.
+ die "Line $i$filename_error not breakable.\n" if $dbline[$i] == 0;
-sub _delete_all_breakpoints {
- print {$OUT} "Deleting all breakpoints...\n";
+ # Mark this file as having breakpoints in it.
+ $had_breakpoints{$filename} |= 1;
- # %had_breakpoints lists every file that had at least one
- # breakpoint in it.
- for my $fn ( keys %had_breakpoints ) {
+ # If there is an action or condition here already ...
+ if ( $dbline{$i} ) {
- # Switch to the desired file temporarily.
- local *dbline = $main::{ '_<' . $fn };
+ # ... swap this condition for the existing one.
+ $dbline{$i} =~ s/^[^\0]*/$cond/;
+ }
+ else {
- $max = $#dbline;
+ # Nothing here - just add the condition.
+ $dbline{$i} = $cond;
- # For all lines in this file ...
- for my $i (1 .. $max) {
+ _set_breakpoint_enabled_status($filename, $i, 1);
+ }
- # If there's a breakpoint or action on this line ...
- if ( defined $dbline{$i} ) {
+ return;
+} ## end sub break_on_line
- # ... remove the breakpoint.
- $dbline{$i} =~ s/\A[^\0]+//;
- if ( $dbline{$i} =~ s/\A\0?\z// ) {
- # Remove the entry altogether if no action is there.
- _remove_breakpoint_entry($fn, $i);
- }
- } ## end if (defined $dbline{$i...
- } ## end for $i (1 .. $max)
+=head3 cmd_b_line(line, [condition]) (command)
- # If, after we turn off the "there were breakpoints in this file"
- # bit, the entry in %had_breakpoints for this file is zero,
- # we should remove this file from the hash.
- if ( not $had_breakpoints{$fn} &= (~1) ) {
- delete $had_breakpoints{$fn};
- }
- } ## end for my $fn (keys %had_breakpoints)
+Wrapper for C<break_on_line>. Prints the failure message if it
+doesn't work.
- # Kill off all the other breakpoints that are waiting for files that
- # haven't been loaded yet.
- undef %postponed;
- undef %postponed_file;
- undef %break_on_load;
+=cut
+
+sub cmd_b_line {
+ if (not eval { break_on_line(@_); 1 }) {
+ local $\ = '';
+ print $OUT $@ and return;
+ }
return;
-}
+} ## end sub cmd_b_line
-sub _delete_breakpoint_from_line {
- my ($i) = @_;
+=head3 cmd_b_filename_line(line, [condition]) (command)
- # Woops. This line wasn't breakable at all.
- die "Line $i not breakable.\n" if $dbline[$i] == 0;
+Wrapper for C<break_on_filename_line>. Prints the failure message if it
+doesn't work.
- # Kill the condition, but leave any action.
- $dbline{$i} =~ s/\A[^\0]*//;
+=cut
- # Remove the entry entirely if there's no action left.
- if ($dbline{$i} eq '') {
- _remove_breakpoint_entry($filename, $i);
+sub cmd_b_filename_line {
+ if (not eval { break_on_filename_line(@_); 1 }) {
+ local $\ = '';
+ print $OUT $@ and return;
}
return;
}
-sub delete_breakpoint {
+=head3 break_on_filename_line(file, line, [condition]) (API)
+
+Switches to the file specified and then calls C<break_on_line> to set
+the breakpoint.
+
+=cut
+
+sub break_on_filename_line {
+ my $f = shift;
my $i = shift;
+ my $cond = @_ ? shift(@_) : 1;
- # If we got a line, delete just that one.
- if ( defined($i) ) {
- _delete_breakpoint_from_line($i);
- }
- # No line; delete them all.
- else {
- _delete_all_breakpoints();
- }
+ # Switch the magical hash temporarily.
+ local *dbline = $main::{ '_<' . $f };
+
+ # Localize the variables that break_on_line uses to make its message.
+ local $filename_error = " of '$f'";
+ local $filename = $f;
+
+ # Add the breakpoint.
+ break_on_line( $i, $cond );
return;
-}
+} ## end sub break_on_filename_line
-=head3 cmd_stop (command)
+=head3 break_on_filename_line_range(file, from, to, [condition]) (API)
-This is meant to be part of the new command API, but it isn't called or used
-anywhere else in the debugger. XXX It is probably meant for use in development
-of new commands.
+Switch to another file, search the range of lines specified for an
+executable one, and put a breakpoint on the first one you find.
=cut
-sub cmd_stop { # As on ^C, but not signal-safy.
- $signal = 1;
-}
+sub break_on_filename_line_range {
+ my $f = shift;
+ my $from = shift;
+ my $to = shift;
+ my $cond = @_ ? shift(@_) : 1;
-=head3 C<cmd_e> - threads
+ # Find a breakable line if there is one.
+ my $i = breakable_line_in_filename( $f, $from, $to );
-Display the current thread id:
+ # Add the breakpoint.
+ break_on_filename_line( $f, $i, $cond );
- e
+ return;
+} ## end sub break_on_filename_line_range
-This could be how (when implemented) to send commands to this thread id (e cmd)
-or that thread id (e tid cmd).
+=head3 subroutine_filename_lines(subname, [condition]) (API)
-=cut
+Search for a subroutine within a given file. The condition is ignored.
+Uses C<find_sub> to locate the desired subroutine.
-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
+=cut
-=head3 C<cmd_E> - list of thread ids
+sub subroutine_filename_lines {
+ my ( $subname ) = @_;
-Display the list of available thread ids:
+ # Returned value from find_sub() is fullpathname:startline-endline.
+ # The match creates the list (fullpathname, start, end).
+ return (find_sub($subname) =~ /^(.*):(\d+)-(\d+)$/);
+} ## end sub subroutine_filename_lines
- E
+=head3 break_subroutine(subname) (API)
-This could be used (when implemented) to send commands to all threads (E cmd).
+Places a break on the first line possible in the specified subroutine. Uses
+C<subroutine_filename_lines> to find the subroutine, and
+C<break_on_filename_line_range> to place the break.
=cut
-sub 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)
+sub break_subroutine {
+ my $subname = shift;
-Does the work of either
+ # Get filename, start, and end.
+ my ( $file, $s, $e ) = subroutine_filename_lines($subname)
+ or die "Subroutine $subname not found.\n";
-=over 4
-=item *
+ # Null condition changes to '1' (always true).
+ my $cond = @_ ? shift(@_) : 1;
-Showing all the debugger help
+ # Put a break the first place possible in the range of lines
+ # that make up this subroutine.
+ break_on_filename_line_range( $file, $s, $e, $cond );
-=item *
+ return;
+} ## end sub break_subroutine
-Showing help for a specific command
+=head3 cmd_b_sub(subname, [condition]) (command)
-=back
+We take the incoming subroutine name and fully-qualify it as best we can.
-=cut
+=over 4
-use vars qw($help);
-use vars qw($summary);
+=item 1. If it's already fully-qualified, leave it alone.
-sub cmd_h {
- my $cmd = shift;
+=item 2. Try putting it in the current package.
- # If we have no operand, assume null.
- my $line = shift || '';
+=item 3. If it's not there, try putting it in CORE::GLOBAL if it exists there.
- # 'h h'. Print the long-format help.
- if ( $line =~ /\Ah\s*\z/ ) {
- print_help($help);
- }
+=item 4. If it starts with '::', put it in 'main::'.
- # 'h <something>'. Search for the command and print only its help.
- elsif ( my ($asked) = $line =~ /\A(\S.*)\z/ ) {
+=back
- # support long commands; otherwise bogus errors
- # happen when you ask for h on <CR> for example
- my $qasked = quotemeta($asked); # for searching; we don't
- # want to use it as a pattern.
- # XXX: finds CR but not <CR>
+After all this cleanup, we call C<break_subroutine> to try to set the
+breakpoint.
- # Search the help string for the command.
- if (
- $help =~ /^ # Start of a line
- <? # Optional '<'
- (?:[IB]<) # Optional markup
- $qasked # The requested command
- /mx
- )
- {
+=cut
- # It's there; pull it out and print it.
- while (
- $help =~ /^
- (<? # Optional '<'
- (?:[IB]<) # Optional markup
- $qasked # The command
- ([\s\S]*?) # Description line(s)
- \n) # End of last description line
- (?!\s) # Next line not starting with
- # whitespace
- /mgx
- )
- {
- print_help($1);
- }
- }
+sub cmd_b_sub {
+ my $subname = shift;
+ my $cond = @_ ? shift : 1;
- # Not found; not a debugger command.
- else {
- print_help("B<$asked> is not a debugger command.\n");
- }
- } ## end elsif ($line =~ /^(\S.*)$/)
+ # If the subname isn't a code reference, qualify it so that
+ # break_subroutine() will work right.
+ if ( ref($subname) ne 'CODE' ) {
- # 'h' - print the summary help.
- else {
- print_help($summary);
- }
-} ## end sub cmd_h
+ # Not Perl 4.
+ $subname =~ s/'/::/g;
+ my $s = $subname;
-=head3 C<cmd_i> - inheritance display
+ # Put it in this package unless it's already qualified.
+ if ($subname !~ /::/)
+ {
+ $subname = $package . '::' . $subname;
+ };
-Display the (nested) parentage of the module or object given.
+ # 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.
+ my $core_name = "CORE::GLOBAL::$s";
+ if ((!defined(&$subname))
+ and ($s !~ /::/)
+ and (defined &{$core_name}))
+ {
+ $subname = $core_name;
+ }
-=cut
+ # Put it in package 'main' if it has a leading ::.
+ if ($subname =~ /\A::/)
+ {
+ $subname = "main" . $subname;
+ }
+ } ## end if ( ref($subname) ne 'CODE' ) {
-sub cmd_i {
- my $cmd = shift;
- my $line = shift;
- foreach my $isa ( split( /\s+/, $line ) ) {
- $evalarg = $isa;
- ($isa) = DB::eval();
- no strict 'refs';
- print join(
- ', ',
- map {
- "$_"
- . (
- defined( ${"$_\::VERSION"} )
- ? ' ' . ${"$_\::VERSION"}
- : undef )
- } @{mro::get_linear_isa(ref($isa) || $isa)}
- );
- print "\n";
+ # Try to set the breakpoint.
+ if (not eval { break_subroutine( $subname, $cond ); 1 }) {
+ local $\ = '';
+ print {$OUT} $@;
+ return;
}
-} ## end sub cmd_i
-=head3 C<cmd_l> - list lines (command)
+ return;
+} ## end sub cmd_b_sub
-Most of the command is taken up with transforming all the different line
-specification syntaxes into 'start-stop'. After that is done, the command
-runs a loop over C<@dbline> for the specified range of lines. It handles
-the printing of each line and any markers (C<==E<gt>> for current line,
-C<b> for break on this line, C<a> for action on this line, C<:> for this
-line breakable).
+=head3 C<cmd_B> - delete breakpoint(s) (command)
-We save the last line listed in the C<$start> global for further listing
-later.
+The command mostly parses the command line and tries to turn the argument
+into a line spec. If it can't, it uses the current line. It then calls
+C<delete_breakpoint> to actually do the work.
+
+If C<*> is specified, C<cmd_B> calls C<delete_breakpoint> with no arguments,
+thereby deleting all the breakpoints.
=cut
-sub _min {
- my $min = shift;
- foreach my $v (@_) {
- if ($min > $v) {
- $min = $v;
+sub cmd_B {
+ my $cmd = shift;
+
+ # No line spec? Use dbline.
+ # If there is one, use it if it's non-zero, or wipe it out if it is.
+ my $line = ( $_[0] =~ /\A\./ ) ? $dbline : (shift || '');
+ my $dbline = shift;
+
+ # If the line was dot, make the line the current one.
+ $line =~ s/^\./$dbline/;
+
+ # If it's * we're deleting all the breakpoints.
+ if ( $line eq '*' ) {
+ if (not eval { delete_breakpoint(); 1 }) {
+ print {$OUT} $@;
}
}
- return $min;
-}
-sub _max {
- my $max = shift;
- foreach my $v (@_) {
- if ($max < $v) {
- $max = $v;
+ # If there is a line spec, delete the breakpoint on that line.
+ elsif ( $line =~ /\A(\S.*)/ ) {
+ if (not eval { delete_breakpoint( $line || $dbline ); 1 }) {
+ local $\ = '';
+ print {$OUT} $@;
}
+ } ## end elsif ($line =~ /^(\S.*)/)
+
+ # No line spec.
+ else {
+ print {$OUT}
+ "Deleting a breakpoint requires a line number, or '*' for all\n"
+ ; # hint
}
- return $max;
-}
-sub _minify_to_max {
- my $ref = shift;
+ return;
+} ## end sub cmd_B
- $$ref = _min($$ref, $max);
+=head3 delete_breakpoint([line]) (API)
- return;
-}
+This actually does the work of deleting either a single breakpoint, or all
+of them.
-sub _cmd_l_handle_var_name {
- my $var_name = shift;
+For a single line, we look for it in C<@dbline>. If it's nonbreakable, we
+just drop out with a message saying so. If it is, we remove the condition
+part of the 'condition\0action' that says there's a breakpoint here. If,
+after we've done that, there's nothing left, we delete the corresponding
+line in C<%dbline> to signal that no action needs to be taken for this line.
- $evalarg = $var_name;
+For all breakpoints, we iterate through the keys of C<%had_breakpoints>,
+which lists all currently-loaded files which have breakpoints. We then look
+at each line in each of these files, temporarily switching the C<%dbline>
+and C<@dbline> structures to point to the files in question, and do what
+we did in the single line case: delete the condition in C<@dbline>, and
+delete the key in C<%dbline> if nothing's left.
- my ($s) = DB::eval();
+We then wholesale delete C<%postponed>, C<%postponed_file>, and
+C<%break_on_load>, because these structures contain breakpoints for files
+and code that haven't been loaded yet. We can just kill these off because there
+are no magical debugger structures associated with them.
- # Ooops. Bad scalar.
- if ($@) {
- print {$OUT} "Error: $@\n";
- next CMD;
- }
+=cut
- # 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 _remove_breakpoint_entry {
+ my ($fn, $i) = @_;
- # Call self recursively to really do the command.
- return _cmd_l_main( $s );
+ delete $dbline{$i};
+ _delete_breakpoint_data_ref($fn, $i);
+
+ return;
}
-sub _cmd_l_handle_subname {
+sub _delete_all_breakpoints {
+ print {$OUT} "Deleting all breakpoints...\n";
- my $s = $subname;
+ # %had_breakpoints lists every file that had at least one
+ # breakpoint in it.
+ for my $fn ( keys %had_breakpoints ) {
- # De-Perl4.
- $subname =~ s/\'/::/;
+ # Switch to the desired file temporarily.
+ local *dbline = $main::{ '_<' . $fn };
- # Put it in this package unless it starts with ::.
- $subname = $package . "::" . $subname unless $subname =~ /::/;
+ $max = $#dbline;
- # 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"};
+ # For all lines in this file ...
+ for my $i (1 .. $max) {
- # Put leading '::' names into 'main::'.
- $subname = "main" . $subname if substr( $subname, 0, 2 ) eq "::";
+ # If there's a breakpoint or action on this line ...
+ if ( defined $dbline{$i} ) {
- # Get name:start-stop from find_sub, and break this up at
- # colons.
- my @pieces = split( /:/, find_sub($subname) || $sub{$subname} );
+ # ... remove the breakpoint.
+ $dbline{$i} =~ s/\A[^\0]+//;
+ if ( $dbline{$i} =~ s/\A\0?\z// ) {
+ # Remove the entry altogether if no action is there.
+ _remove_breakpoint_entry($fn, $i);
+ }
+ } ## end if (defined $dbline{$i...
+ } ## end for $i (1 .. $max)
- # Pull off start-stop.
- my $subrange = pop @pieces;
+ # If, after we turn off the "there were breakpoints in this file"
+ # bit, the entry in %had_breakpoints for this file is zero,
+ # we should remove this file from the hash.
+ if ( not $had_breakpoints{$fn} &= (~1) ) {
+ delete $had_breakpoints{$fn};
+ }
+ } ## end for my $fn (keys %had_breakpoints)
- # If the name contained colons, the split broke it up.
- # Put it back together.
- $file = join( ':', @pieces );
+ # Kill off all the other breakpoints that are waiting for files that
+ # haven't been loaded yet.
+ undef %postponed;
+ undef %postponed_file;
+ undef %break_on_load;
- # 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";
- }
+ return;
+}
- # Switch debugger's magic structures.
- *dbline = $main::{ '_<' . $file };
- $max = $#dbline;
- $filename = $file;
- } ## end if ($file ne $filename)
+sub _delete_breakpoint_from_line {
+ my ($i) = @_;
- # 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/-.*/+/;
- }
+ # Woops. This line wasn't breakable at all.
+ die "Line $i not breakable.\n" if $dbline[$i] == 0;
- # Call self recursively to list the range.
- return _cmd_l_main( $subrange );
- } ## end if ($subrange)
+ # Kill the condition, but leave any action.
+ $dbline{$i} =~ s/\A[^\0]*//;
- # Couldn't find it.
- else {
- print {$OUT} "Subroutine $subname not found.\n";
- return;
+ # Remove the entry entirely if there's no action left.
+ if ($dbline{$i} eq '') {
+ _remove_breakpoint_entry($filename, $i);
}
+
+ return;
}
-sub _cmd_l_empty {
- # Compute new range to list.
- $incr = $window - 1;
+sub delete_breakpoint {
+ my $i = shift;
- # Recurse to do it.
- return _cmd_l_main( $start . '-' . ( $start + $incr ) );
+ # If we got a line, delete just that one.
+ if ( defined($i) ) {
+ _delete_breakpoint_from_line($i);
+ }
+ # No line; delete them all.
+ else {
+ _delete_all_breakpoints();
+ }
+
+ return;
}
-sub _cmd_l_plus {
- my ($new_start, $new_incr) = @_;
+=head3 cmd_stop (command)
- # Don't reset start for 'l +nnn'.
- $start = $new_start if $new_start;
+This is meant to be part of the new command API, but it isn't called or used
+anywhere else in the debugger. XXX It is probably meant for use in development
+of new commands.
- # Increment for list. Use window size if not specified.
- # (Allows 'l +' to work.)
- $incr = $new_incr || ($window - 1);
+=cut
- # Create a line range we'll understand, and recurse to do it.
- return _cmd_l_main( $start . '-' . ( $start + $incr ) );
+sub cmd_stop { # As on ^C, but not signal-safy.
+ $signal = 1;
}
-sub _cmd_l_calc_initial_end_and_i {
- my ($spec, $start_match, $end_match) = @_;
+=head3 C<cmd_e> - threads
- # Determine end point; use end of file if not specified.
- my $end = ( !defined $start_match ) ? $max :
- ( $end_match ? $end_match : $start_match );
+Display the current thread id:
- # Go on to the end, and then stop.
- _minify_to_max(\$end);
+ e
- # Determine start line.
- my $i = $start_match;
+This could be how (when implemented) to send commands to this thread id (e cmd)
+or that thread id (e tid cmd).
- if ($i eq '.') {
- $i = $spec;
+=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
- $i = _max($i, 1);
+=head3 C<cmd_E> - list of thread ids
- $incr = $end - $i;
+Display the list of available thread ids:
- return ($end, $i);
-}
+ E
-sub _cmd_l_range {
- my ($spec, $current_line, $start_match, $end_match) = @_;
+This could be used (when implemented) to send commands to all threads (E cmd).
- my ($end, $i) =
- _cmd_l_calc_initial_end_and_i($spec, $start_match, $end_match);
+=cut
- # 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_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";
}
- # 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++ ) {
+} ## end sub cmd_E
- # Check for breakpoints and actions.
- my ( $stop, $action );
- if ($dbline{$i}) {
- ( $stop, $action ) = split( /\0/, $dbline{$i} );
- }
+=head3 C<cmd_h> - help command (command)
- # ==> 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 ? ':' : ' ' );
+Does the work of either
- # Add break and action indicators.
- $arrow .= 'b' if $stop;
- $arrow .= 'a' if $action;
+=over 4
- # Print the line.
- print {$OUT} "$i$arrow\t", $dbline[$i];
+=item *
- # Move on to the next line. Drop out on an interrupt.
- if ($signal) {
- $i++;
- last I_TO_END;
- }
- } ## end for (; $i <= $end ; $i++)
+Showing all the debugger help
- # 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)
+=item *
- # 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);
+Showing help for a specific command
- return;
-}
+=back
-sub _cmd_l_main {
- my $spec = shift;
+=cut
- # If this is '-something', delete any spaces after the dash.
- $spec =~ s/\A-\s*\z/-/;
+use vars qw($help);
+use vars qw($summary);
- # 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);
+sub cmd_h {
+ my $cmd = shift;
+
+ # If we have no operand, assume null.
+ my $line = shift || '';
+
+ # 'h h'. Print the long-format help.
+ if ( $line =~ /\Ah\s*\z/ ) {
+ print_help($help);
}
- return;
-} ## end sub cmd_l
+ # 'h <something>'. Search for the command and print only its help.
+ elsif ( my ($asked) = $line =~ /\A(\S.*)\z/ ) {
+
+ # support long commands; otherwise bogus errors
+ # happen when you ask for h on <CR> for example
+ my $qasked = quotemeta($asked); # for searching; we don't
+ # want to use it as a pattern.
+ # XXX: finds CR but not <CR>
-sub cmd_l {
- my (undef, $line) = @_;
+ # Search the help string for the command.
+ if (
+ $help =~ /^ # Start of a line
+ <? # Optional '<'
+ (?:[IB]<) # Optional markup
+ $qasked # The requested command
+ /mx
+ )
+ {
- return _cmd_l_main($line);
-}
+ # It's there; pull it out and print it.
+ while (
+ $help =~ /^
+ (<? # Optional '<'
+ (?:[IB]<) # Optional markup
+ $qasked # The command
+ ([\s\S]*?) # Description line(s)
+ \n) # End of last description line
+ (?!\s) # Next line not starting with
+ # whitespace
+ /mgx
+ )
+ {
+ print_help($1);
+ }
+ }
+
+ # Not found; not a debugger command.
+ else {
+ print_help("B<$asked> is not a debugger command.\n");
+ }
+ } ## end elsif ($line =~ /^(\S.*)$/)
+
+ # 'h' - print the summary help.
+ else {
+ print_help($summary);
+ }
+} ## end sub cmd_h
=head3 C<cmd_L> - list breakpoints, actions, and watch expressions (command)
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;
# If there are any, list them.
if ( @have and ( $break_wanted or $action_wanted ) ) {
- 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;
- }
- } ## end for $line (sort { $a <=>...
- if ($signal) {
- last POSTPONED_SCANS;
- }
- } ## 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 ) {
# 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>
# 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, and controls into like
+ # '^D'.
+ require 'meta_notation.pm';
+ $_ = _meta_notation($_) if /[[:^print:]]/a;
+
+ 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;
$i++
)
{
-
- # 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)
+ # if the sub has args ($h true), make an anonymous array of the
+ # dumped args.
+ my $args = $h ? _dump_trace_calc_save_args($nothard) : undef;
# If context is true, this is array (@)context.
# If context is false, this is scalar ($) context.
# happen' trap.)
$context = $context ? '@' : ( defined $context ? "\$" : '.' );
- # if the sub has args ($h true), make an anonymous array of the
- # dumped args.
- $args = $h ? [@a] : undef;
-
# remove trailing newline-whitespace-semicolon-end of line sequence
# from the eval text, if any.
$e =~ s/\n\s*\;\s*\Z// if $e;
# 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" : "" ),
if ($tty) {
my ( $i, $o ) = split $tty, /,/;
$o = $i unless defined $o;
- open( IN, "<$i" ) or die "Cannot open TTY '$i' for read: $!";
- open( OUT, ">$o" ) or die "Cannot open TTY '$o' for write: $!";
+ open( IN, '<', $i ) or die "Cannot open TTY '$i' for read: $!";
+ open( OUT, '>', $o ) or die "Cannot open TTY '$o' for write: $!";
$IN = \*IN;
$OUT = \*OUT;
- $OUT->autoflush(1);
+ _autoflush($OUT);
} ## end if ($tty)
# We don't have a TTY - try to find one via Term::Rendezvous.
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,
# Add it to the terminal history (if possible).
$term->AddHistory($got)
- if length($got) > 1
+ if length($got) >= option_val("HistItemMinLength", 2)
and defined $term->Features->{addHistory};
return $got;
} ## end if (@typeahead)
Set_list packages up items to be stored in a set of environment variables
(VAR_n, containing the number of items, and VAR_0, VAR_1, etc., containing
the values). Values outside the standard ASCII charset are stored by encoding
-then as hexadecimal values.
+them as hexadecimal values.
=cut
for my $i ( 0 .. $#list ) {
$val = $list[$i];
$val =~ s/\\/\\\\/g;
- $val =~ s/([\0-\37\177\200-\377])/"\\0x" . unpack('H2',$1)/eg;
+ no warnings 'experimental::regex_sets';
+ $val =~ s/ ( (?[ [\000-\xFF] & [:^print:] ]) ) /
+ "\\0x" . unpack('H2',$1)/xaeg;
$ENV{"${stem}_$i"} = $val;
} ## end for $i (0 .. $#list)
} ## end sub set_list
}
# 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;
}
# Open file onto the debugger's filehandles, if you can.
- open IN, $in or die "cannot open '$in' for read: $!";
- open OUT, ">$out" or die "cannot open '$out' for write: $!";
+ open IN, '<', $in or die "cannot open '$in' for read: $!";
+ open OUT, '>', $out or die "cannot open '$out' for write: $!";
# Swap to the new filehandles.
reset_IN_OUT( \*IN, \*OUT );
open ($new_lineinfo_fh , $stream )
or _db_warn("Cannot open '$stream' for write");
$LINEINFO = $new_lineinfo_fh;
- $LINEINFO->autoflush(1);
+ _autoflush($LINEINFO);
}
return $lineinfo;
# wide. If it's wider than that, an extra space will be added.
$help_str =~ s{
^ # only matters at start of line
- ( \040{4} | \t )* # some subcommands are indented
+ ( \ {4} | \t )* # some subcommands are indented
( < ? # so <CR> works
[BI] < [^\t\n] + ) # find an eeevil ornament
( \t+ ) # original separation, discarded
=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
- book
- boot
- bot
- bs2000
- call
- ce
- cheat
- clib
- cn
- compile
- cygwin
- data
- dbmfilter
- debguts
- debtut
- debug
- delta
- dgux
- diag
- doc
- dos
- dsc
- ebcdic
- embed
- 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) {
$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.
$db_stop = 0; # Compiler warning ...
$db_stop = 1 << 30; # ... because this is only used in an eval() later.
- # This variable records how many levels we're nested in debugging. Used
+ # This variable records how many levels we're nested in debugging.
# Used in the debugger prompt, and in determining whether it's all over or
# not.
$level = 0; # Level of recursive debugging
=cut
- if (not $text =~ /::/ and eval { require PadWalker } ) {
+ if (not $text =~ /::/ and eval {
+ local @INC = @INC;
+ pop @INC if $INC[-1] eq '.';
+ require PadWalker } ) {
my $level = 1;
while (1) {
my @info = caller($level);
=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 *
# 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)
# 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 $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