considered to be a breakpoint; C<perl5db.pl> uses C<$break_condition\0$action>.
Values are magical in numeric context: 1 if the line is breakable, 0 if not.
-The scalar C<${"_<$filename"}> simply contains the string C<<< _<$filename> >>>.
+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).
use strict;
-BEGIN {eval 'use IO::Handle'}; # Needed for flush only? breaks under miniperl
+BEGIN {eval 'use IO::Handle'}; # Needed for flush only? breaks under miniperl
BEGIN {
require feature;
# Debugger for Perl 5.00x; perl5db.pl patch level:
use vars qw($VERSION $header);
-$VERSION = '1.39_05';
+$VERSION = '1.39_06';
$header = "perl5db.pl version $VERSION";
use vars qw(
@args
%break_on_load
- @cmdfhs
$CommandSet
$CreateTTY
$DBGR
$dbline
%dbline
$dieLevel
- $evalarg
$filename
- $frame
- $hist
$histfile
$histsize
- $ImmediateStop
$IN
$inhibit_exit
@ini_INC
$ini_warn
- $line
$maxtrace
$od
- $onetimeDump
- $onetimedumpDepth
- %option
@options
$osingle
$otrace
- $OUT
- $packname
$pager
$post
%postponed
@res
$rl
@saved
- $signal
$signalLevel
- $single
- $start
$sub
- %sub
- $subname
$term
- $trace
$usercontext
$warnLevel
- $window
+);
+
+our (
+ @cmdfhs,
+ $evalarg,
+ $frame,
+ $hist,
+ $ImmediateStop,
+ $line,
+ $onetimeDump,
+ $onetimedumpDepth,
+ %option,
+ $OUT,
+ $packname,
+ $signal,
+ $single,
+ $start,
+ %sub,
+ $subname,
+ $trace,
+ $window,
);
# Used to save @ARGV and extract any debugger-related flags.
# Used to prevent the debugger from running nonstop
# after a restart
-use vars qw($second_time);
+our ($second_time);
sub _calc_usercontext {
my ($package) = @_;
you of each new thread created. It will also indicate the thread id in which
we are currently running within the prompt like this:
- [tid] DB<$i>
+ [tid] DB<$i>
Where C<[tid]> is an integer thread id and C<$i> is the familiar debugger
command prompt. The prompt will show: C<[0]> when running under threads, but
=cut
BEGIN {
- # ensure we can share our non-threaded variables or no-op
- if ($ENV{PERL5DB_THREADED}) {
- require threads;
- require threads::shared;
- import threads::shared qw(share);
- $DBGR;
- share(\$DBGR);
- lock($DBGR);
- print "Threads support enabled\n";
- } else {
- *lock = sub(*) {};
- *share = sub(*) {};
- }
+ # ensure we can share our non-threaded variables or no-op
+ if ($ENV{PERL5DB_THREADED}) {
+ require threads;
+ require threads::shared;
+ import threads::shared qw(share);
+ $DBGR;
+ share(\$DBGR);
+ lock($DBGR);
+ print "Threads support enabled\n";
+ } else {
+ *share = sub(\[$@%]) {};
+ }
}
# These variables control the execution of 'dumpvar.pl'.
}
# without threads, $filename is not defined until DB::DB is called
-foreach my $k (keys (%INC)) {
- share(\$main::{'_<'.$filename}) if defined $filename;
-};
+share($main::{'_<'.$filename}) if defined $filename;
# Command-line + PERLLIB:
# Save the contents of @INC before they are modified elsewhere.
$pidprompt = '';
# Sets up $emacs as a synonym for $slave_editor.
-use vars qw($slave_editor);
+our ($slave_editor);
*emacs = $slave_editor if $slave_editor; # May be used in afterinit()...
=head2 READING THE RC FILE
=cut
-use vars qw(@hist @truehist %postponed_file @typeahead);
+use vars qw(%postponed_file @typeahead);
+
+our (@hist, @truehist);
sub _restore_shared_globals_after_restart
{
=cut
-use vars qw($notty $runnonstop $console $tty $LINEINFO);
+use vars qw($notty $console $tty $LINEINFO);
use vars qw($lineinfo $doccmd);
+our ($runnonstop);
+
if ($notty) {
$runnonstop = 1;
- share($runnonstop);
+ share($runnonstop);
}
=pod
Several other systems don't use a specific console. We C<undef $console>
for those (Windows using a slave editor/graphical debugger, NetWare, OS/2
-with a slave editor, Epoc).
+with a slave editor).
=cut
$console = undef;
}
- # EPOC also falls into the 'got to use STDIN' camp.
- if ( $^O eq 'epoc' ) {
- $console = undef;
- }
-
=pod
If there is a TTY hanging around from a parent, we use that as the console.
# and a I/O description to keep track of.
$LINEINFO = $OUT unless defined $LINEINFO;
$lineinfo = $console unless defined $lineinfo;
- # share($LINEINFO); # <- unable to share globs
- share($lineinfo); #
+ # share($LINEINFO); # <- unable to share globs
+ share($lineinfo); #
=pod
=cut
+# $cmd cannot be an our() variable unfortunately (possible perl bug?).
+
use vars qw(
$action
- %alias
$cmd
- $doret
- $fall_off_end
$file
$filename_ini
$finished
%had_breakpoints
- $incr
- $laststep
$level
$max
- @old_watch
$package
- $rc
- $sh
- @stack
- $stack_depth
- @to_watch
$try
- $end
+);
+
+our (
+ %alias,
+ $doret,
+ $end,
+ $fall_off_end,
+ $incr,
+ $laststep,
+ $rc,
+ $sh,
+ $stack_depth,
+ @stack,
+ @to_watch,
+ @old_watch,
);
sub _DB__determine_if_we_should_break
# see if we should stop. If so, remove the one-time sigil.
elsif ($stop) {
$evalarg = "\$DB::signal |= 1 if do {$stop}";
- &eval;
+ 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);
return defined($cmd);
}
+sub _DB__trim_command_and_return_first_component {
+ my ($obj) = @_;
+
+ $cmd =~ s/\A\s+//s; # trim annoying leading whitespace
+ $cmd =~ s/\s+\z//s; # trim annoying trailing whitespace
+
+ my ($verb, $args) = $cmd =~ m{\A(\S*)\s*(.*)}s;
+
+ $obj->cmd_verb($verb);
+ $obj->cmd_args($args);
+
+ return;
+}
+
+sub _DB__handle_f_command {
+ my ($obj) = @_;
+
+ if ($file = $obj->cmd_args) {
+ # help for no arguments (old-style was return from sub).
+ if ( !$file ) {
+ print $OUT
+ "The old f command is now the r command.\n"; # hint
+ print $OUT "The new f command switches filenames.\n";
+ next CMD;
+ } ## end if (!$file)
+
+ # if not in magic file list, try a close match.
+ if ( !defined $main::{ '_<' . $file } ) {
+ if ( ($try) = grep( m#^_<.*$file#, keys %main:: ) ) {
+ {
+ $try = substr( $try, 2 );
+ print $OUT "Choosing $try matching '$file':\n";
+ $file = $try;
+ }
+ } ## end if (($try) = grep(m#^_<.*$file#...
+ } ## end if (!defined $main::{ ...
+
+ # If not successfully switched now, we failed.
+ if ( !defined $main::{ '_<' . $file } ) {
+ print $OUT "No file matching '$file' is loaded.\n";
+ next CMD;
+ }
+
+ # We switched, so switch the debugger internals around.
+ elsif ( $file ne $filename ) {
+ *dbline = $main::{ '_<' . $file };
+ $max = $#dbline;
+ $filename = $file;
+ $start = 1;
+ $cmd = "l";
+ } ## end elsif ($file ne $filename)
+
+ # We didn't switch; say we didn't.
+ else {
+ print $OUT "Already in $file.\n";
+ next CMD;
+ }
+ }
+
+ return;
+}
+
+sub _DB__handle_dot_command {
+ my ($obj) = @_;
+
+ # . command.
+ if ($obj->_is_full('.')) {
+ $incr = -1; # stay at current line
+
+ # Reset everything to the old location.
+ $start = $line;
+ $filename = $filename_ini;
+ *dbline = $main::{ '_<' . $filename };
+ $max = $#dbline;
+
+ # Now where are we?
+ print_lineinfo($obj->position());
+ next CMD;
+ }
+
+ return;
+}
+
+sub _DB__handle_y_command {
+ my ($obj) = @_;
+
+ if (my ($match_level, $match_vars)
+ = $obj->cmd_args =~ /\A(?:(\d*)\s*(.*))?\z/) {
+
+ # See if we've got the necessary support.
+ if (!eval { require PadWalker; PadWalker->VERSION(0.08) }) {
+ my $Err = $@;
+ _db_warn(
+ $Err =~ /locate/
+ ? "PadWalker module not found - please install\n"
+ : $Err
+ );
+ next CMD;
+ }
+
+ # Load up dumpvar if we don't have it. If we can, that is.
+ do 'dumpvar.pl' || die $@ unless defined &main::dumpvar;
+ defined &main::dumpvar
+ or print $OUT "dumpvar.pl not available.\n"
+ and next CMD;
+
+ # Got all the modules we need. Find them and print them.
+ my @vars = split( ' ', $match_vars || '' );
+
+ # Find the pad.
+ my $h = eval { PadWalker::peek_my( ( $match_level || 0 ) + 1 ) };
+
+ # Oops. Can't find it.
+ if (my $Err = $@) {
+ $Err =~ s/ at .*//;
+ _db_warn($Err);
+ next CMD;
+ }
+
+ # Show the desired vars with dumplex().
+ my $savout = select($OUT);
+
+ # Have dumplex dump the lexicals.
+ foreach my $key (sort keys %$h) {
+ dumpvar::dumplex( $key, $h->{$key},
+ defined $option{dumpDepth} ? $option{dumpDepth} : -1,
+ @vars );
+ }
+ select($savout);
+ next CMD;
+ }
+}
+
+sub _DB__handle_c_command {
+ my ($obj) = @_;
+
+ my $i = $obj->cmd_args;
+
+ if ($i =~ m#\A[\w:]*\z#) {
+
+ # Hey, show's over. The debugged program finished
+ # executing already.
+ next CMD if _DB__is_finished();
+
+ # Capture the place to put a one-time break.
+ $subname = $i;
+
+ # Probably not needed, since we finish an interactive
+ # sub-session anyway...
+ # local $filename = $filename;
+ # local *dbline = *dbline; # XXX Would this work?!
+ #
+ # The above question wonders if localizing the alias
+ # to the magic array works or not. Since it's commented
+ # out, we'll just leave that to speculation for now.
+
+ # If the "subname" isn't all digits, we'll assume it
+ # is a subroutine name, and try to find it.
+ if ( $subname =~ /\D/ ) { # subroutine name
+ # Qualify it to the current package unless it's
+ # already qualified.
+ $subname = $package . "::" . $subname
+ unless $subname =~ /::/;
+
+ # find_sub will return "file:line_number" corresponding
+ # to where the subroutine is defined; we call find_sub,
+ # break up the return value, and assign it in one
+ # operation.
+ ( $file, $i ) = ( find_sub($subname) =~ /^(.*):(.*)$/ );
+
+ # Force the line number to be numeric.
+ $i = $i + 0;
+
+ # If we got a line number, we found the sub.
+ if ($i) {
+
+ # Switch all the debugger's internals around so
+ # we're actually working with that file.
+ $filename = $file;
+ *dbline = $main::{ '_<' . $filename };
+
+ # Mark that there's a breakpoint in this file.
+ $had_breakpoints{$filename} |= 1;
+
+ # Scan forward to the first executable line
+ # after the 'sub whatever' line.
+ $max = $#dbline;
+ my $_line_num = $i;
+ while ($dbline[$_line_num] == 0 && $_line_num< $max)
+ {
+ $_line_num++;
+ }
+ $i = $_line_num;
+ } ## end if ($i)
+
+ # We didn't find a sub by that name.
+ else {
+ print $OUT "Subroutine $subname not found.\n";
+ next CMD;
+ }
+ } ## end if ($subname =~ /\D/)
+
+ # At this point, either the subname was all digits (an
+ # absolute line-break request) or we've scanned through
+ # the code following the definition of the sub, looking
+ # for an executable, which we may or may not have found.
+ #
+ # If $i (which we set $subname from) is non-zero, we
+ # got a request to break at some line somewhere. On
+ # one hand, if there wasn't any real subroutine name
+ # involved, this will be a request to break in the current
+ # file at the specified line, so we have to check to make
+ # sure that the line specified really is breakable.
+ #
+ # On the other hand, if there was a subname supplied, the
+ # preceding block has moved us to the proper file and
+ # location within that file, and then scanned forward
+ # looking for the next executable line. We have to make
+ # sure that one was found.
+ #
+ # On the gripping hand, we can't do anything unless the
+ # current value of $i points to a valid breakable line.
+ # Check that.
+ if ($i) {
+
+ # Breakable?
+ if ( $dbline[$i] == 0 ) {
+ print $OUT "Line $i not breakable.\n";
+ next CMD;
+ }
+
+ # Yes. Set up the one-time-break sigil.
+ $dbline{$i} =~ s/($|\0)/;9$1/; # add one-time-only b.p.
+ _enable_breakpoint_temp_enabled_status($filename, $i);
+ } ## end if ($i)
+
+ # Turn off stack tracing from here up.
+ for my $j (0 .. $stack_depth) {
+ $stack[ $j ] &= ~1;
+ }
+ last CMD;
+ }
+
+ return;
+}
+
+sub _DB__handle_forward_slash_command {
+ my ($obj) = @_;
+
+ # The pattern as a string.
+ use vars qw($inpat);
+
+ if (($inpat) = $cmd =~ m#\A/(.*)\z#) {
+
+ # Remove the final slash.
+ $inpat =~ s:([^\\])/$:$1:;
+
+ # If the pattern isn't null ...
+ if ( $inpat ne "" ) {
+
+ # Turn of warn and die procesing for a bit.
+ local $SIG{__DIE__};
+ local $SIG{__WARN__};
+
+ # Create the pattern.
+ eval 'no strict q/vars/; $inpat =~ m' . "\a$inpat\a";
+ if ( $@ ne "" ) {
+
+ # Oops. Bad pattern. No biscuit.
+ # Print the eval error and go back for more
+ # commands.
+ print {$OUT} "$@";
+ next CMD;
+ }
+ $obj->pat($inpat);
+ } ## end if ($inpat ne "")
+
+ # Set up to stop on wrap-around.
+ $end = $start;
+
+ # Don't move off the current line.
+ $incr = -1;
+
+ my $pat = $obj->pat;
+
+ # Done in eval so nothing breaks if the pattern
+ # does something weird.
+ eval
+ {
+ no strict q/vars/;
+ for (;;) {
+ # Move ahead one line.
+ ++$start;
+
+ # Wrap if we pass the last line.
+ if ($start > $max) {
+ $start = 1;
+ }
+
+ # Stop if we have gotten back to this line again,
+ last if ($start == $end);
+
+ # A hit! (Note, though, that we are doing
+ # case-insensitive matching. Maybe a qr//
+ # expression would be better, so the user could
+ # do case-sensitive matching if desired.
+ if ($dbline[$start] =~ m/$pat/i) {
+ if ($slave_editor) {
+ # Handle proper escaping in the slave.
+ print {$OUT} "\032\032$filename:$start:0\n";
+ }
+ else {
+ # Just print the line normally.
+ print {$OUT} "$start:\t",$dbline[$start],"\n";
+ }
+ # And quit since we found something.
+ last;
+ }
+ }
+ };
+
+ if ($@) {
+ warn $@;
+ }
+
+ # If we wrapped, there never was a match.
+ if ( $start == $end ) {
+ print {$OUT} "/$pat/: not found\n";
+ }
+ next CMD;
+ }
+
+ return;
+}
+
+sub _DB__handle_question_mark_command {
+ my ($obj) = @_;
+
+ # ? - backward pattern search.
+ if (my ($inpat) = $cmd =~ m#\A\?(.*)\z#) {
+
+ # Get the pattern, remove trailing question mark.
+ $inpat =~ s:([^\\])\?$:$1:;
+
+ # If we've got one ...
+ if ( $inpat ne "" ) {
+
+ # Turn off die & warn handlers.
+ local $SIG{__DIE__};
+ local $SIG{__WARN__};
+ eval '$inpat =~ m' . "\a$inpat\a";
+
+ if ( $@ ne "" ) {
+
+ # Ouch. Not good. Print the error.
+ print $OUT $@;
+ next CMD;
+ }
+ $obj->pat($inpat);
+ } ## end if ($inpat ne "")
+
+ # Where we are now is where to stop after wraparound.
+ $end = $start;
+
+ # Don't move away from this line.
+ $incr = -1;
+
+ my $pat = $obj->pat;
+ # Search inside the eval to prevent pattern badness
+ # from killing us.
+ eval {
+ no strict q/vars/;
+ for (;;) {
+ # Back up a line.
+ --$start;
+
+ # Wrap if we pass the first line.
+
+ $start = $max if ($start <= 0);
+
+ # Quit if we get back where we started,
+ last if ($start == $end);
+
+ # Match?
+ if ($dbline[$start] =~ m/$pat/i) {
+ if ($slave_editor) {
+ # Yep, follow slave editor requirements.
+ print $OUT "\032\032$filename:$start:0\n";
+ }
+ else {
+ # Yep, just print normally.
+ print $OUT "$start:\t",$dbline[$start],"\n";
+ }
+
+ # Found, so done.
+ last;
+ }
+ }
+ };
+
+ # Say we failed if the loop never found anything,
+ if ( $start == $end ) {
+ print {$OUT} "?$pat?: not found\n";
+ }
+ next CMD;
+ }
+
+ return;
+}
+
+sub _DB__handle_restart_and_rerun_commands {
+ my ($obj) = @_;
+
+ my $cmd_cmd = $obj->cmd_verb;
+ my $cmd_params = $obj->cmd_args;
+ # R - restart execution.
+ # rerun - controlled restart execution.
+ if ($cmd_cmd eq 'rerun' or $cmd_params eq '') {
+ my @args = ($cmd_cmd eq 'R' ? restart() : rerun($cmd_params));
+
+ # Close all non-system fds for a clean restart. A more
+ # correct method would be to close all fds that were not
+ # open when the process started, but this seems to be
+ # hard. See "debugger 'R'estart and open database
+ # connections" on p5p.
+
+ my $max_fd = 1024; # default if POSIX can't be loaded
+ if (eval { require POSIX }) {
+ eval { $max_fd = POSIX::sysconf(POSIX::_SC_OPEN_MAX()) };
+ }
+
+ if (defined $max_fd) {
+ foreach ($^F+1 .. $max_fd-1) {
+ next unless open FD_TO_CLOSE, "<&=$_";
+ close(FD_TO_CLOSE);
+ }
+ }
+
+ # And run Perl again. We use exec() to keep the
+ # PID stable (and that way $ini_pids is still valid).
+ exec(@args) or print {$OUT} "exec failed: $!\n";
+
+ last CMD;
+ }
+
+ return;
+}
+
+sub _DB__handle_run_command_in_pager_command {
+ my ($obj) = @_;
+
+ if ($cmd =~ m#\A\|\|?\s*[^|]#) {
+ if ( $pager =~ /^\|/ ) {
+
+ # Default pager is into a pipe. Redirect I/O.
+ open( SAVEOUT, ">&STDOUT" )
+ || _db_warn("Can't save STDOUT");
+ open( STDOUT, ">&OUT" )
+ || _db_warn("Can't redirect STDOUT");
+ } ## end if ($pager =~ /^\|/)
+ else {
+
+ # Not into a pipe. STDOUT is safe.
+ open( SAVEOUT, ">&OUT" ) || _db_warn("Can't save DB::OUT");
+ }
+
+ # Fix up environment to record we have less if so.
+ fix_less();
+
+ unless ( $obj->piped(scalar ( open( OUT, $pager ) ) ) ) {
+
+ # Couldn't open pipe to pager.
+ _db_warn("Can't pipe output to '$pager'");
+ if ( $pager =~ /^\|/ ) {
+
+ # Redirect I/O back again.
+ open( OUT, ">&STDOUT" ) # XXX: lost message
+ || _db_warn("Can't restore DB::OUT");
+ open( STDOUT, ">&SAVEOUT" )
+ || _db_warn("Can't restore STDOUT");
+ close(SAVEOUT);
+ } ## end if ($pager =~ /^\|/)
+ else {
+
+ # Redirect I/O. STDOUT already safe.
+ open( OUT, ">&STDOUT" ) # XXX: lost message
+ || _db_warn("Can't restore DB::OUT");
+ }
+ next CMD;
+ } ## end unless ($piped = open(OUT,...
+
+ # Set up broken-pipe handler if necessary.
+ $SIG{PIPE} = \&DB::catch
+ if $pager =~ /^\|/
+ && ( "" eq $SIG{PIPE} || "DEFAULT" eq $SIG{PIPE} );
+
+ OUT->autoflush(1);
+ # Save current filehandle, and put it back.
+ $obj->selected(scalar( select(OUT) ));
+ # Don't put it back if pager was a pipe.
+ if ($cmd !~ /\A\|\|/)
+ {
+ select($obj->selected());
+ $obj->selected("");
+ }
+
+ # Trim off the pipe symbols and run the command now.
+ $cmd =~ s#\A\|+\s*##;
+ redo PIPE;
+ }
+
+ return;
+}
+
+sub _DB__handle_m_command {
+ my ($obj) = @_;
+
+ if ($cmd =~ s#\Am\s+([\w:]+)\s*\z# #) {
+ methods($1);
+ next CMD;
+ }
+
+ # m expr - set up DB::eval to do the work
+ if ($cmd =~ s#\Am\b# #) { # Rest gets done by DB::eval()
+ $onetimeDump = 'methods'; # method output gets used there
+ }
+
+ return;
+}
+
+sub _DB__at_end_of_every_command {
+ my ($obj) = @_;
+
+ # At the end of every command:
+ if ($obj->piped) {
+
+ # Unhook the pipe mechanism now.
+ if ( $pager =~ /^\|/ ) {
+
+ # No error from the child.
+ $? = 0;
+
+ # we cannot warn here: the handle is missing --tchrist
+ close(OUT) || print SAVEOUT "\nCan't close DB::OUT\n";
+
+ # most of the $? crud was coping with broken cshisms
+ # $? is explicitly set to 0, so this never runs.
+ if ($?) {
+ print SAVEOUT "Pager '$pager' failed: ";
+ if ( $? == -1 ) {
+ print SAVEOUT "shell returned -1\n";
+ }
+ elsif ( $? >> 8 ) {
+ print SAVEOUT ( $? & 127 )
+ ? " (SIG#" . ( $? & 127 ) . ")"
+ : "", ( $? & 128 ) ? " -- core dumped" : "", "\n";
+ }
+ else {
+ print SAVEOUT "status ", ( $? >> 8 ), "\n";
+ }
+ } ## end if ($?)
+
+ # Reopen filehandle for our output (if we can) and
+ # restore STDOUT (if we can).
+ open( OUT, ">&STDOUT" ) || _db_warn("Can't restore DB::OUT");
+ open( STDOUT, ">&SAVEOUT" )
+ || _db_warn("Can't restore STDOUT");
+
+ # Turn off pipe exception handler if necessary.
+ $SIG{PIPE} = "DEFAULT" if $SIG{PIPE} eq \&DB::catch;
+
+ # Will stop ignoring SIGPIPE if done like nohup(1)
+ # does SIGINT but Perl doesn't give us a choice.
+ } ## end if ($pager =~ /^\|/)
+ else {
+
+ # Non-piped "pager". Just restore STDOUT.
+ open( OUT, ">&SAVEOUT" ) || _db_warn("Can't restore DB::OUT");
+ }
+
+ # Close filehandle pager was using, restore the normal one
+ # if necessary,
+ close(SAVEOUT);
+
+ if ($obj->selected() ne "") {
+ select($obj->selected);
+ $obj->selected("");
+ }
+
+ # No pipes now.
+ $obj->piped("");
+ } ## end if ($piped)
+
+ 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 {
# lock the debugger and get the thread id for the prompt
my ($prefix, $after, $infix);
my $pat;
my $explicit_stop;
+ my $piped;
+ my $selected;
if ($ENV{PERL5DB_THREADED}) {
$tid = eval { "[".threads->tid."]" };
}
+ my $cmd_verb;
+ my $cmd_args;
+
my $obj = DB::Obj->new(
{
position => \$position,
after => \$after,
explicit_stop => \$explicit_stop,
infix => \$infix,
+ cmd_args => \$cmd_args,
+ cmd_verb => \$cmd_verb,
+ pat => \$pat,
+ piped => \$piped,
+ selected => \$selected,
},
);
# Preserve current values of $@, $!, $^E, $,, $/, $\, $^W.
# The code being debugged may have altered them.
- &save;
+ DB::save();
# Since DB::DB gets called after every line, we can use caller() to
# figure out where we last were executing. Sneaky, eh? This works because
#
# If we have a terminal for input, and we get something back
# from readline(), keep on processing.
- my $piped;
- my $selected;
CMD:
while (_DB__read_next_cmd($tid))
{
- share($cmd);
+ share($cmd);
# ... try to execute the input as debugger commands.
# Don't stop running.
# Handle continued commands (ending with \):
if ($cmd =~ s/\\\z/\n/) {
- $cmd .= &readline(" cont: ");
+ $cmd .= DB::readline(" cont: ");
redo CMD;
}
=cut
# Empty input means repeat the last command.
- $cmd =~ /^$/ && ( $cmd = $laststep );
+ if ($cmd eq '') {
+ $cmd = $laststep;
+ }
chomp($cmd); # get rid of the annoying extra newline
- push( @hist, $cmd ) if length($cmd) > 1;
+ if (length($cmd) >= 2) {
+ push( @hist, $cmd );
+ }
push( @truehist, $cmd );
- share(@hist);
- share(@truehist);
+ 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: {
- $cmd =~ s/^\s+//s; # trim annoying leading whitespace
- $cmd =~ s/\s+$//s; # trim annoying trailing whitespace
- my ($i) = split( /\s+/, $cmd );
+ _DB__trim_command_and_return_first_component($obj);
=head3 COMMAND ALIASES
=cut
# See if there's an alias for the command, and set it up if so.
- if ( $alias{$i} ) {
+ if ( $alias{$cmd_verb} ) {
# Squelch signal handling; we want to keep control here
# if something goes loco during the alias eval.
# scope! Otherwise, we can't see the special debugger
# variables, or get to the debugger's subs. (Well, we
# _could_, but why make it even more complicated?)
- eval "\$cmd =~ $alias{$i}";
+ eval "\$cmd =~ $alias{$cmd_verb}";
if ($@) {
local $\ = '';
- print $OUT "Couldn't evaluate '$i' alias: $@";
+ print $OUT "Couldn't evaluate '$cmd_verb' alias: $@";
next CMD;
}
- } ## end if ($alias{$i})
+ _DB__trim_command_and_return_first_component($obj);
+ } ## end if ($alias{$cmd_verb})
=head3 MAIN-LINE COMMANDS
=cut
- if ($cmd eq 'q') {
- $fall_off_end = 1;
- clean_ENV();
- exit $?;
+ # All of these commands were remapped in perl 5.8.0;
+ # we send them off to the secondary dispatcher (see below).
+ $obj->_handle_special_char_cmd_wrapper_commands;
+ _DB__trim_command_and_return_first_component($obj);
+
+ if (my $cmd_rec = $cmd_lookup{$cmd_verb}) {
+ my $type = $cmd_rec->{t};
+ my $val = $cmd_rec->{v};
+ if ($type eq 'm') {
+ $obj->$val();
+ }
+ elsif ($type eq 's') {
+ $val->($obj);
+ }
}
=head4 C<t> - trace [n]
Turn tracing on or off. Inverts the appropriate bit in C<$trace> (q.v.).
If level is specified, set C<$trace_to_depth>.
-=cut
-
- if (my ($levels) = $cmd =~ /\At(?:\s+(\d+))?\z/) {
- $trace ^= 1;
- local $\ = '';
- $trace_to_depth = $levels ? $stack_depth + $levels : 1E9;
- print $OUT "Trace = "
- . ( ( $trace & 1 )
- ? ( $levels ? "on (to level $trace_to_depth)" : "on" )
- : "off" ) . "\n";
- next CMD;
- }
-
=head4 C<S> - list subroutines matching/not matching a pattern
Walks through C<%sub>, checking to see whether or not to print the name.
-=cut
-
- if (my ($print_all_subs, $should_reverse, $Spatt)
- = $cmd =~ /\AS(\s+(!)?(.+))?\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;
-
- # Need to make these sane here.
- local $\ = '';
- local $, = '';
-
- # Search through the debugger's magical hash of subs.
- # If $nocheck is true, just print the sub name.
- # Otherwise, check it against the pattern. We then use
- # the XOR trick to reverse the condition as required.
- foreach $subname ( sort( keys %sub ) ) {
- if ( $Snocheck or $Srev ^ ( $subname =~ /$Spatt/ ) ) {
- print $OUT $subname, "\n";
- }
- }
- next CMD;
- }
-
=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.
-=cut
-
- $cmd =~ s/^X\b/V $package/;
-
=head4 C<V> - list variables
Uses C<dumpvar.pl> to dump out the current values for selected variables.
-=cut
-
- # Bare V commands get the currently-being-debugged package
- # added.
- if ($cmd eq "V") {
- $cmd = "V $package";
- }
-
- # V - show variables in package.
- if (my ($new_packname, $new_vars_str) =
- $cmd =~ /\AV\b\s*(\S+)\s*(.*)/) {
-
- # Save the currently selected filehandle and
- # force output to debugger's filehandle (dumpvar
- # just does "print" for output).
- my $savout = select($OUT);
-
- # Grab package name and variables to dump.
- $packname = $new_packname;
- my @vars = split( ' ', $new_vars_str );
-
- # If main::dumpvar isn't here, get it.
- do 'dumpvar.pl' || die $@ unless defined &main::dumpvar;
- if ( defined &main::dumpvar ) {
-
- # We got it. Turn off subroutine entry/exit messages
- # for the moment, along with return values.
- local $frame = 0;
- local $doret = -2;
-
- # must detect sigpipe failures - not catching
- # then will cause the debugger to die.
- eval {
- &main::dumpvar(
- $packname,
- defined $option{dumpDepth}
- ? $option{dumpDepth}
- : -1, # assume -1 unless specified
- @vars
- );
- };
-
- # The die doesn't need to include the $@, because
- # it will automatically get propagated for us.
- if ($@) {
- die unless $@ =~ /dumpvar print failed/;
- }
- } ## end if (defined &main::dumpvar)
- else {
-
- # Couldn't load dumpvar.
- print $OUT "dumpvar.pl not available.\n";
- }
-
- # Restore the output filehandle, and go round again.
- select($savout);
- next CMD;
- }
-
=head4 C<x> - evaluate and print an expression
Hands the expression off to C<DB::eval>, setting it up to print the value
via C<dumpvar.pl> instead of just printing it directly.
-=cut
-
- if ($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 ( $cmd =~ s#\A\s*(\d+)(?=\s)# #) {
- $onetimedumpDepth = $1;
- }
- }
-
=head4 C<m> - print methods
Just uses C<DB::methods> to determine what methods are available.
-=cut
-
- if ($cmd =~ s#\Am\s+([\w:]+)\s*\z# #) {
- methods($1);
- next CMD;
- }
-
- # m expr - set up DB::eval to do the work
- if ($cmd =~ s#\Am\b# #) { # Rest gets done by DB::eval()
- $onetimeDump = 'methods'; # method output gets used there
- }
-
=head4 C<f> - switch files
-=cut
-
- if (($file) = $cmd =~ /\Af\b\s*(.*)/) {
- $file =~ s/\s+$//;
-
- # help for no arguments (old-style was return from sub).
- if ( !$file ) {
- print $OUT
- "The old f command is now the r command.\n"; # hint
- print $OUT "The new f command switches filenames.\n";
- next CMD;
- } ## end if (!$file)
-
- # if not in magic file list, try a close match.
- if ( !defined $main::{ '_<' . $file } ) {
- if ( ($try) = grep( m#^_<.*$file#, keys %main:: ) ) {
- {
- $try = substr( $try, 2 );
- print $OUT "Choosing $try matching '$file':\n";
- $file = $try;
- }
- } ## end if (($try) = grep(m#^_<.*$file#...
- } ## end if (!defined $main::{ ...
-
- # If not successfully switched now, we failed.
- if ( !defined $main::{ '_<' . $file } ) {
- print $OUT "No file matching '$file' is loaded.\n";
- next CMD;
- }
-
- # We switched, so switch the debugger internals around.
- elsif ( $file ne $filename ) {
- *dbline = $main::{ '_<' . $file };
- $max = $#dbline;
- $filename = $file;
- $start = 1;
- $cmd = "l";
- } ## end elsif ($file ne $filename)
-
- # We didn't switch; say we didn't.
- else {
- print $OUT "Already in $file.\n";
- next CMD;
- }
- }
+Switch to a different filename.
=head4 C<.> - return to last-executed line.
We set C<$incr> to -1 to indicate that the debugger shouldn't move ahead,
and then we look up the line in the magical C<%dbline> hash.
-=cut
-
- # . command.
- if ($cmd eq '.') {
- $incr = -1; # stay at current line
-
- # Reset everything to the old location.
- $start = $line;
- $filename = $filename_ini;
- *dbline = $main::{ '_<' . $filename };
- $max = $#dbline;
-
- # Now where are we?
- print_lineinfo($position);
- next CMD;
- }
-
=head4 C<-> - back one window
We change C<$start> to be one window back; if we go back past the first line,
currently-executing line, and then put a C<l $start +> (list one window from
C<$start>) in C<$cmd> to be executed later.
-=cut
-
- # - - back a window.
- if ($cmd eq '-') {
-
- # back up by a window; go to 1 if back too far.
- $start -= $incr + $window + 1;
- $start = 1 if $start <= 0;
- $incr = $window - 1;
-
- # Generate and execute a "l +" command (handled below).
- $cmd = 'l ' . ($start) . '+';
- }
-
=head3 PRE-580 COMMANDS VS. NEW COMMANDS: C<a, A, b, B, h, l, L, M, o, O, P, v, w, W, E<lt>, E<lt>E<lt>, E<0x7B>, E<0x7B>E<0x7B>>
In Perl 5.8.0, a realignment of the commands was done to fix up a number of
them. At this point, we check for the new commands and call C<cmd_wrapper> to
deal with them instead of processing them in-line.
-=cut
-
- # All of these commands were remapped in perl 5.8.0;
- # we send them off to the secondary dispatcher (see below).
- if (my ($cmd_letter, $my_arg) = $cmd =~ /\A([aAbBeEhilLMoOPvwW]\b|[<>\{]{1,2})\s*(.*)/so) {
- &cmd_wrapper( $cmd_letter, $my_arg, $line );
- next CMD;
- }
-
=head4 C<y> - List lexicals in higher scope
Uses C<PadWalker> to find the lexicals supplied as arguments in a scope
above the current one and then displays then using C<dumpvar.pl>.
-=cut
-
- if (my ($match_level, $match_vars)
- = $cmd =~ /^y(?:\s+(\d*)\s*(.*))?$/) {
-
- # See if we've got the necessary support.
- eval { require PadWalker; PadWalker->VERSION(0.08) }
- or &warn(
- $@ =~ /locate/
- ? "PadWalker module not found - please install\n"
- : $@
- )
- and next CMD;
-
- # Load up dumpvar if we don't have it. If we can, that is.
- do 'dumpvar.pl' || die $@ unless defined &main::dumpvar;
- defined &main::dumpvar
- or print $OUT "dumpvar.pl not available.\n"
- and next CMD;
-
- # Got all the modules we need. Find them and print them.
- my @vars = split( ' ', $match_vars || '' );
-
- # Find the pad.
- my $h = eval { PadWalker::peek_my( ( $match_level || 0 ) + 1 ) };
-
- # Oops. Can't find it.
- $@ and $@ =~ s/ at .*//, &warn($@), next CMD;
-
- # Show the desired vars with dumplex().
- my $savout = select($OUT);
-
- # Have dumplex dump the lexicals.
- dumpvar::dumplex( $_, $h->{$_},
- defined $option{dumpDepth} ? $option{dumpDepth} : -1,
- @vars )
- for sort keys %$h;
- select($savout);
- next CMD;
- }
-
=head3 COMMANDS NOT WORKING AFTER PROGRAM ENDS
All of the commands below this point don't work after the program being
when entered (see C<DB::sub>). We also save the C<n> command in C<$laststep>,
so a null command knows what to re-execute.
-=cut
-
- # n - next
- if ($cmd eq 'n') {
- next CMD if _DB__is_finished();
-
- # Single step, but don't enter subs.
- $single = 2;
-
- # Save for empty command (repeat last).
- $laststep = $cmd;
- last CMD;
- }
-
=head4 C<s> - single-step, entering subs
Sets C<$single> to 1, which causes C<DB::sub> to continue tracing inside
subs. Also saves C<s> as C<$lastcmd>.
-=cut
-
- # s - single step.
- if ($cmd eq 's') {
-
- # Get out and restart the command loop if program
- # has finished.
- next CMD if _DB__is_finished();
-
- # Single step should enter subs.
- $single = 1;
-
- # Save for empty command (repeat last).
- $laststep = $cmd;
- last CMD;
- }
-
=head4 C<c> - run continuously, setting an optional breakpoint
Most of the code for this command is taken up with locating the optional
the appropriate one-time-break in C<@dbline> and then turn off single-stepping
in this and all call levels above this one.
-=cut
-
- # c - start continuous execution.
- if (($i) = $cmd =~ m#\Ac\b\s*([\w:]*)\s*\z#) {
-
- # Hey, show's over. The debugged program finished
- # executing already.
- next CMD if _DB__is_finished();
-
- # Capture the place to put a one-time break.
- $subname = $i;
-
- # Probably not needed, since we finish an interactive
- # sub-session anyway...
- # local $filename = $filename;
- # local *dbline = *dbline; # XXX Would this work?!
- #
- # The above question wonders if localizing the alias
- # to the magic array works or not. Since it's commented
- # out, we'll just leave that to speculation for now.
-
- # If the "subname" isn't all digits, we'll assume it
- # is a subroutine name, and try to find it.
- if ( $subname =~ /\D/ ) { # subroutine name
- # Qualify it to the current package unless it's
- # already qualified.
- $subname = $package . "::" . $subname
- unless $subname =~ /::/;
-
- # find_sub will return "file:line_number" corresponding
- # to where the subroutine is defined; we call find_sub,
- # break up the return value, and assign it in one
- # operation.
- ( $file, $i ) = ( find_sub($subname) =~ /^(.*):(.*)$/ );
-
- # Force the line number to be numeric.
- $i += 0;
-
- # If we got a line number, we found the sub.
- if ($i) {
-
- # Switch all the debugger's internals around so
- # we're actually working with that file.
- $filename = $file;
- *dbline = $main::{ '_<' . $filename };
-
- # Mark that there's a breakpoint in this file.
- $had_breakpoints{$filename} |= 1;
-
- # Scan forward to the first executable line
- # after the 'sub whatever' line.
- $max = $#dbline;
- ++$i while $dbline[$i] == 0 && $i < $max;
- } ## end if ($i)
-
- # We didn't find a sub by that name.
- else {
- print $OUT "Subroutine $subname not found.\n";
- next CMD;
- }
- } ## end if ($subname =~ /\D/)
-
- # At this point, either the subname was all digits (an
- # absolute line-break request) or we've scanned through
- # the code following the definition of the sub, looking
- # for an executable, which we may or may not have found.
- #
- # If $i (which we set $subname from) is non-zero, we
- # got a request to break at some line somewhere. On
- # one hand, if there wasn't any real subroutine name
- # involved, this will be a request to break in the current
- # file at the specified line, so we have to check to make
- # sure that the line specified really is breakable.
- #
- # On the other hand, if there was a subname supplied, the
- # preceding block has moved us to the proper file and
- # location within that file, and then scanned forward
- # looking for the next executable line. We have to make
- # sure that one was found.
- #
- # On the gripping hand, we can't do anything unless the
- # current value of $i points to a valid breakable line.
- # Check that.
- if ($i) {
-
- # Breakable?
- if ( $dbline[$i] == 0 ) {
- print $OUT "Line $i not breakable.\n";
- next CMD;
- }
-
- # Yes. Set up the one-time-break sigil.
- $dbline{$i} =~ s/($|\0)/;9$1/; # add one-time-only b.p.
- _enable_breakpoint_temp_enabled_status($filename, $i);
- } ## end if ($i)
-
- # Turn off stack tracing from here up.
- for my $i (0 .. $stack_depth) {
- $stack[ $i ] &= ~1;
- }
- last CMD;
- }
-
=head4 C<r> - return from a subroutine
For C<r> to work properly, the debugger has to stop execution again
we are printing return values when a C<r> is executed, set C<$doret>
appropriately, and force us out of the command loop.
-=cut
-
- # r - return from the current subroutine.
- if ($cmd eq 'r') {
-
- # Can't do anything if the program's over.
- next CMD if _DB__is_finished();
-
- # Turn on stack trace.
- $stack[$stack_depth] |= 1;
-
- # Print return value unless the stack is empty.
- $doret = $option{PrintRet} ? $stack_depth - 1 : -2;
- last CMD;
- }
-
=head4 C<T> - stack trace
Just calls C<DB::print_trace>.
-=cut
-
- if ($cmd eq 'T') {
- print_trace( $OUT, 1 ); # skip DB
- next CMD;
- }
-
=head4 C<w> - List window around current line.
Just calls C<DB::cmd_w>.
-=cut
-
- if (my ($arg) = $cmd =~ /\Aw\b\s*(.*)/s) {
- &cmd_w( 'w', $arg );
- next CMD;
- }
-
=head4 C<W> - watch-expression processing.
Just calls C<DB::cmd_W>.
-=cut
-
- if (my ($arg) = $cmd =~ /\AW\b\s*(.*)/s) {
- &cmd_W( 'W', $arg );
- next CMD;
- }
-
=head4 C</> - search forward for a string in the source
We take the argument and treat it as a pattern. If it turns out to be a
=cut
- # The pattern as a string.
- use vars qw($inpat);
-
- if (($inpat) = $cmd =~ m#\A/(.*)\z#) {
-
- # Remove the final slash.
- $inpat =~ s:([^\\])/$:$1:;
-
- # If the pattern isn't null ...
- if ( $inpat ne "" ) {
-
- # Turn of warn and die procesing for a bit.
- local $SIG{__DIE__};
- local $SIG{__WARN__};
-
- # Create the pattern.
- eval 'no strict q/vars/; $inpat =~ m' . "\a$inpat\a";
- if ( $@ ne "" ) {
-
- # Oops. Bad pattern. No biscuit.
- # Print the eval error and go back for more
- # commands.
- print $OUT "$@";
- next CMD;
- }
- $pat = $inpat;
- } ## end if ($inpat ne "")
-
- # Set up to stop on wrap-around.
- $end = $start;
-
- # Don't move off the current line.
- $incr = -1;
-
- # Done in eval so nothing breaks if the pattern
- # does something weird.
- eval '
- no strict q/vars/;
- for (;;) {
- # Move ahead one line.
- ++$start;
-
- # Wrap if we pass the last line.
- $start = 1 if ($start > $max);
-
- # Stop if we have gotten back to this line again,
- last if ($start == $end);
-
- # A hit! (Note, though, that we are doing
- # case-insensitive matching. Maybe a qr//
- # expression would be better, so the user could
- # do case-sensitive matching if desired.
- if ($dbline[$start] =~ m' . "\a$pat\a" . 'i) {
- if ($slave_editor) {
- # Handle proper escaping in the slave.
- print $OUT "\032\032$filename:$start:0\n";
- }
- else {
- # Just print the line normally.
- print $OUT "$start:\t",$dbline[$start],"\n";
- }
- # And quit since we found something.
- last;
- }
- } ';
-
- # If we wrapped, there never was a match.
- print $OUT "/$pat/: not found\n" if ( $start == $end );
- next CMD;
- }
+ _DB__handle_forward_slash_command($obj);
=head4 C<?> - search backward for a string in the source
=cut
- # ? - backward pattern search.
- if (my ($inpat) = $cmd =~ m#\A\?(.*)\z#) {
-
- # Get the pattern, remove trailing question mark.
- $inpat =~ s:([^\\])\?$:$1:;
-
- # If we've got one ...
- if ( $inpat ne "" ) {
-
- # Turn off die & warn handlers.
- local $SIG{__DIE__};
- local $SIG{__WARN__};
- eval '$inpat =~ m' . "\a$inpat\a";
-
- if ( $@ ne "" ) {
-
- # Ouch. Not good. Print the error.
- print $OUT $@;
- next CMD;
- }
- $pat = $inpat;
- } ## end if ($inpat ne "")
-
- # Where we are now is where to stop after wraparound.
- $end = $start;
-
- # Don't move away from this line.
- $incr = -1;
-
- # Search inside the eval to prevent pattern badness
- # from killing us.
- eval '
- no strict q/vars/;
- for (;;) {
- # Back up a line.
- --$start;
-
- # Wrap if we pass the first line.
-
- $start = $max if ($start <= 0);
-
- # Quit if we get back where we started,
- last if ($start == $end);
-
- # Match?
- if ($dbline[$start] =~ m' . "\a$pat\a" . 'i) {
- if ($slave_editor) {
- # Yep, follow slave editor requirements.
- print $OUT "\032\032$filename:$start:0\n";
- }
- else {
- # Yep, just print normally.
- print $OUT "$start:\t",$dbline[$start],"\n";
- }
-
- # Found, so done.
- last;
- }
- } ';
-
- # Say we failed if the loop never found anything,
- print $OUT "?$pat?: not found\n" if ( $start == $end );
- next CMD;
- }
+ _DB__handle_question_mark_command($obj);
=head4 C<$rc> - Recall command
=cut
# $rc - recall command.
- if (my ($minus, $arg) = $cmd =~ m#\A$rc+\s*(-)?(\d+)?\z#) {
-
- # No arguments, take one thing off history.
- pop(@hist) if length($cmd) > 1;
-
- # Relative (- found)?
- # Y - index back from most recent (by 1 if bare minus)
- # N - go to that particular command slot or the last
- # thing if nothing following.
- $i = $minus ? ( $#hist - ( $arg || 1 ) ) : ( $arg || $#hist );
-
- # Pick out the command desired.
- $cmd = $hist[$i];
-
- # Print the command to be executed and restart the loop
- # with that command in the buffer.
- print $OUT $cmd, "\n";
- redo CMD;
- }
+ $obj->_handle_rc_recall_command;
=head4 C<$sh$sh> - C<system()> command
-Calls the C<DB::system()> to handle the command. This keeps the C<STDIN> and
+Calls the C<_db_system()> to handle the command. This keeps the C<STDIN> and
C<STDOUT> from getting messed up.
=cut
- # $sh$sh - run a shell command (if it's all ASCII).
- # Can't run shell commands with Unicode in the debugger, hmm.
- if (my ($arg) = $cmd =~ m#\A$sh$sh\s*(.*)#ms) {
-
- # System it.
- &system($arg);
- next CMD;
- }
+ $obj->_handle_sh_command;
=head4 C<$rc I<pattern> $rc> - Search command history
=cut
- # $rc pattern $rc - find a command in the history.
- if (my ($arg) = $cmd =~ /\A$rc([^$rc].*)\z/) {
-
- # Create the pattern to use.
- $pat = "^$arg";
-
- # Toss off last entry if length is >1 (and it always is).
- pop(@hist) if length($cmd) > 1;
-
- # Look backward through the history.
- for ( $i = $#hist ; $i ; --$i ) {
- # Stop if we find it.
- last if $hist[$i] =~ /$pat/;
- }
-
- if ( !$i ) {
-
- # Never found it.
- print $OUT "No such command!\n\n";
- next CMD;
- }
-
- # Found it. Put it in the buffer, print it, and process it.
- $cmd = $hist[$i];
- print $OUT $cmd, "\n";
- redo CMD;
- }
+ $obj->_handle_rc_search_history_command;
=head4 C<$sh> - Invoke a shell
-Uses C<DB::system> to invoke a shell.
+Uses C<_db_system()> to invoke a shell.
=cut
- # $sh - start a shell.
- if ($cmd =~ /\A$sh\z/) {
-
- # Run the user's shell. If none defined, run Bourne.
- # We resume execution when the shell terminates.
- &system( $ENV{SHELL} || "/bin/sh" );
- next CMD;
- }
-
=head4 C<$sh I<command>> - Force execution of a command in a shell
Like the above, but the command is passed to the shell. Again, we use
-C<DB::system> to avoid problems with C<STDIN> and C<STDOUT>.
-
-=cut
-
- # $sh command - start a shell and run a command in it.
- if (my ($arg) = $cmd =~ m#\A$sh\s*(.*)#ms) {
-
- # XXX: using csh or tcsh destroys sigint retvals!
- #&system($1); # use this instead
-
- # use the user's shell, or Bourne if none defined.
- &system( $ENV{SHELL} || "/bin/sh", "-c", $arg );
- next CMD;
- }
+C<_db_system()> to avoid problems with C<STDIN> and C<STDOUT>.
=head4 C<H> - display commands in history
Prints the contents of C<@hist> (if any).
-=cut
-
- if ($cmd =~ /\AH\b\s*\*/) {
- @hist = @truehist = ();
- print $OUT "History cleansed\n";
- next CMD;
- }
-
- if (my ($num)
- = $cmd =~ /\AH\b\s*(?:-(\d+))?/) {
-
- # Anything other than negative numbers is ignored by
- # the (incorrect) pattern, so this test does nothing.
- $end = $num ? ( $#hist - $num ) : 0;
-
- # Set to the minimum if less than zero.
- $hist = 0 if $hist < 0;
-
- # Start at the end of the array.
- # Stay in while we're still above the ending value.
- # Tick back by one each time around the loop.
- for ( $i = $#hist ; $i > $end ; $i-- ) {
-
- # Print the command unless it has no arguments.
- print $OUT "$i: ", $hist[$i], "\n"
- unless $hist[$i] =~ /^.?$/;
- }
- next CMD;
- }
-
=head4 C<man, doc, perldoc> - look up documentation
Just calls C<runman()> to print the appropriate document.
=cut
- # man, perldoc, doc - show manual pages.
- if (my ($man_page)
- = $cmd =~ /\A(?:man|(?:perl)?doc)\b(?:\s+([^(]*))?\z/) {
- runman($man_page);
- next CMD;
- }
+ $obj->_handle_doc_command;
=head4 C<p> - print
Builds a C<print EXPR> expression in the C<$cmd>; this will get executed at
the bottom of the loop.
-=cut
-
- my $print_cmd = 'print {$DB::OUT} ';
- # p - print (no args): print $_.
- if ($cmd eq 'p') {
- $cmd = $print_cmd . '$_';
- }
-
- # p - print the given expression.
- $cmd =~ s/\Ap\b/$print_cmd /;
-
=head4 C<=> - define command alias
Manipulates C<%alias> to add or list command aliases.
-=cut
-
- # = - set up a command alias.
- if ($cmd =~ s/\A=\s*//) {
- my @keys;
- if ( length $cmd == 0 ) {
-
- # No args, get current aliases.
- @keys = sort keys %alias;
- }
- elsif ( my ( $k, $v ) = ( $cmd =~ /^(\S+)\s+(\S.*)/ ) ) {
-
- # Creating a new alias. $k is alias name, $v is
- # alias value.
-
- # can't use $_ or kill //g state
- for my $x ( $k, $v ) {
-
- # Escape "alarm" characters.
- $x =~ s/\a/\\a/g;
- }
-
- # Substitute key for value, using alarm chars
- # as separators (which is why we escaped them in
- # the command).
- $alias{$k} = "s\a$k\a$v\a";
-
- # Turn off standard warn and die behavior.
- local $SIG{__DIE__};
- local $SIG{__WARN__};
-
- # Is it valid Perl?
- unless ( eval "sub { s\a$k\a$v\a }; 1" ) {
-
- # Nope. Bad alias. Say so and get out.
- print $OUT "Can't alias $k to $v: $@\n";
- delete $alias{$k};
- next CMD;
- }
-
- # We'll only list the new one.
- @keys = ($k);
- } ## end elsif (my ($k, $v) = ($cmd...
-
- # The argument is the alias to list.
- else {
- @keys = ($cmd);
- }
-
- # List aliases.
- for my $k (@keys) {
-
- # Messy metaquoting: Trim the substitution code off.
- # We use control-G as the delimiter because it's not
- # likely to appear in the alias.
- if ( ( my $v = $alias{$k} ) =~ s\as\a$k\a(.*)\a$\a1\a ) {
-
- # Print the alias.
- print $OUT "$k\t= $1\n";
- }
- elsif ( defined $alias{$k} ) {
-
- # Couldn't trim it off; just print the alias code.
- print $OUT "$k\t$alias{$k}\n";
- }
- else {
-
- # No such, dude.
- print "No alias for $k\n";
- }
- } ## end for my $k (@keys)
- next CMD;
- }
-
=head4 C<source> - read commands from a file.
Opens a lexical filehandle and stacks it on C<@cmdfhs>; C<DB::readline> will
pick it up.
-=cut
-
- # source - read commands from a file (or pipe!) and execute.
- if (my ($sourced_fn) = $cmd =~ /\Asource\s+(.*\S)/) {
- if ( open my $fh, $sourced_fn ) {
-
- # Opened OK; stick it in the list of file handles.
- push @cmdfhs, $fh;
- }
- else {
-
- # Couldn't open it.
- &warn("Can't execute '$sourced_fn': $!\n");
- }
- next CMD;
- }
+=head4 C<enable> C<disable> - enable or disable breakpoints
- if (my ($which_cmd, $position)
- = $cmd =~ /^(enable|disable)\s+(\S+)\s*$/) {
-
- my ($fn, $line_num);
- if ($position =~ m{\A\d+\z})
- {
- $fn = $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
- {
- &warn("Wrong spec for enable/disable argument.\n");
- }
-
- if (defined($fn)) {
- if (_has_breakpoint_data_ref($fn, $line_num)) {
- _set_breakpoint_enabled_status($fn, $line_num,
- ($which_cmd eq 'enable' ? 1 : '')
- );
- }
- else {
- &warn("No breakpoint set at ${fn}:${line_num}\n");
- }
- }
-
- next CMD;
- }
+This enables or disables breakpoints.
=head4 C<save> - send current history to a file
Note that all C<^(save|source)>'s are commented out with a view to minimise recursion.
-=cut
-
- # save source - write commands to a file for later use
- if (my ($new_fn) = $cmd =~ /\Asave\s*(.*)\z/) {
- my $filename = $new_fn || '.perl5dbrc'; # default?
- if ( open my $fh, '>', $filename ) {
-
- # chomp to remove extraneous newlines from source'd files
- chomp( my @truelist =
- map { m/^\s*(save|source)/ ? "#$_" : $_ }
- @truehist );
- print $fh join( "\n", @truelist );
- print "commands saved in $file\n";
- }
- else {
- &warn("Can't save debugger commands in '$new_fn': $!\n");
- }
- next CMD;
- }
-
=head4 C<R> - restart
Restart the debugger session.
Return to any given position in the B<true>-history list
-=cut
-
- # R - restart execution.
- # rerun - controlled restart execution.
- if (my ($cmd_cmd, $cmd_params) =
- $cmd =~ /\A((?:R)|(?:rerun\s*(.*)))\z/) {
- my @args = ($cmd_cmd eq 'R' ? restart() : rerun($cmd_params));
-
- # Close all non-system fds for a clean restart. A more
- # correct method would be to close all fds that were not
- # open when the process started, but this seems to be
- # hard. See "debugger 'R'estart and open database
- # connections" on p5p.
-
- my $max_fd = 1024; # default if POSIX can't be loaded
- if (eval { require POSIX }) {
- eval { $max_fd = POSIX::sysconf(POSIX::_SC_OPEN_MAX()) };
- }
-
- if (defined $max_fd) {
- foreach ($^F+1 .. $max_fd-1) {
- next unless open FD_TO_CLOSE, "<&=$_";
- close(FD_TO_CLOSE);
- }
- }
-
- # And run Perl again. We use exec() to keep the
- # PID stable (and that way $ini_pids is still valid).
- exec(@args) || print $OUT "exec failed: $!\n";
-
- last CMD;
- }
-
=head4 C<|, ||> - pipe output through the pager.
For C<|>, we save C<OUT> (the debugger's output filehandle) and C<STDOUT>
=cut
# || - run command in the pager, with output to DB::OUT.
- if ($cmd =~ m#\A\|\|?\s*[^|]#) {
- if ( $pager =~ /^\|/ ) {
-
- # Default pager is into a pipe. Redirect I/O.
- open( SAVEOUT, ">&STDOUT" )
- || &warn("Can't save STDOUT");
- open( STDOUT, ">&OUT" )
- || &warn("Can't redirect STDOUT");
- } ## end if ($pager =~ /^\|/)
- else {
-
- # Not into a pipe. STDOUT is safe.
- open( SAVEOUT, ">&OUT" ) || &warn("Can't save DB::OUT");
- }
-
- # Fix up environment to record we have less if so.
- fix_less();
-
- unless ( $piped = open( OUT, $pager ) ) {
-
- # Couldn't open pipe to pager.
- &warn("Can't pipe output to '$pager'");
- if ( $pager =~ /^\|/ ) {
-
- # Redirect I/O back again.
- open( OUT, ">&STDOUT" ) # XXX: lost message
- || &warn("Can't restore DB::OUT");
- open( STDOUT, ">&SAVEOUT" )
- || &warn("Can't restore STDOUT");
- close(SAVEOUT);
- } ## end if ($pager =~ /^\|/)
- else {
-
- # Redirect I/O. STDOUT already safe.
- open( OUT, ">&STDOUT" ) # XXX: lost message
- || &warn("Can't restore DB::OUT");
- }
- next CMD;
- } ## end unless ($piped = open(OUT,...
-
- # Set up broken-pipe handler if necessary.
- $SIG{PIPE} = \&DB::catch
- if $pager =~ /^\|/
- && ( "" eq $SIG{PIPE} || "DEFAULT" eq $SIG{PIPE} );
-
- OUT->autoflush(1);
- # Save current filehandle, and put it back.
- $selected = select(OUT);
- # Don't put it back if pager was a pipe.
- select($selected), $selected = "" unless $cmd =~ /^\|\|/;
-
- # Trim off the pipe symbols and run the command now.
- $cmd =~ s#\A\|+\s*##;
- redo PIPE;
- }
+ _DB__handle_run_command_in_pager_command($obj);
=head3 END OF COMMAND PARSING
=cut
- # t - turn trace on.
- if ($cmd =~ s#\At\s+(\d+)?#\$DB::trace |= 1;\n#) {
- my $trace_arg = $1;
- $trace_to_depth = $trace_arg ? $stack_depth||0 + $1 : 1E9;
- }
-
- # s - single-step. Remember the last command was 's'.
- if ($cmd =~ s/\As\s/\$DB::single = 1;\n/) {
- $laststep = 's';
- }
-
- # n - single-step, but not into subs. Remember last command
- # was 'n'.
- if ($cmd =~ s#\An\s#\$DB::single = 2;\n#) {
- $laststep = 'n';
- }
-
} # PIPE:
+ # trace an expression
+ $cmd =~ s/^t\s/\$DB::trace |= 1;\n/;
+
# Make sure the flag that says "the debugger's running" is
# still on, to make sure we get control again.
$evalarg = "\$^D = \$^D | \$DB::db_stop;\n$cmd";
$onetimedumpDepth = undef;
}
elsif ( $term_pid == $$ ) {
- eval { # May run under miniperl, when not available...
+ eval { # May run under miniperl, when not available...
STDOUT->flush();
STDERR->flush();
- };
+ };
# XXX If this is the master pid, print a newline.
- print $OUT "\n";
+ print {$OUT} "\n";
}
} ## end while (($term || &setterm...
=cut
continue { # CMD:
-
- # At the end of every command:
- if ($piped) {
-
- # Unhook the pipe mechanism now.
- if ( $pager =~ /^\|/ ) {
-
- # No error from the child.
- $? = 0;
-
- # we cannot warn here: the handle is missing --tchrist
- close(OUT) || print SAVEOUT "\nCan't close DB::OUT\n";
-
- # most of the $? crud was coping with broken cshisms
- # $? is explicitly set to 0, so this never runs.
- if ($?) {
- print SAVEOUT "Pager '$pager' failed: ";
- if ( $? == -1 ) {
- print SAVEOUT "shell returned -1\n";
- }
- elsif ( $? >> 8 ) {
- print SAVEOUT ( $? & 127 )
- ? " (SIG#" . ( $? & 127 ) . ")"
- : "", ( $? & 128 ) ? " -- core dumped" : "", "\n";
- }
- else {
- print SAVEOUT "status ", ( $? >> 8 ), "\n";
- }
- } ## end if ($?)
-
- # Reopen filehandle for our output (if we can) and
- # restore STDOUT (if we can).
- open( OUT, ">&STDOUT" ) || &warn("Can't restore DB::OUT");
- open( STDOUT, ">&SAVEOUT" )
- || &warn("Can't restore STDOUT");
-
- # Turn off pipe exception handler if necessary.
- $SIG{PIPE} = "DEFAULT" if $SIG{PIPE} eq \&DB::catch;
-
- # Will stop ignoring SIGPIPE if done like nohup(1)
- # does SIGINT but Perl doesn't give us a choice.
- } ## end if ($pager =~ /^\|/)
- else {
-
- # Non-piped "pager". Just restore STDOUT.
- open( OUT, ">&SAVEOUT" ) || &warn("Can't restore DB::OUT");
- }
-
- # Close filehandle pager was using, restore the normal one
- # if necessary,
- close(SAVEOUT);
- select($selected), $selected = "" unless $selected eq "";
-
- # No pipes now.
- $piped = "";
- } ## end if ($piped)
+ _DB__at_end_of_every_command($obj);
} # CMD:
=head3 COMMAND LOOP TERMINATION
{
no strict 'refs';
- foreach my $slot_name (qw(after explicit_stop infix position prefix)) {
+ 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;
# Check for whether we should be running continuously or not.
# _After_ the perl program is compiled, $single is set to 1:
- if ( $DB::single and not $DB::second_time++ ) {
+ if ( $single and not $second_time++ ) {
# Options say run non-stop. Run until we get an interrupt.
- if ($DB::runnonstop) { # Disable until signal
+ 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 .. $DB::stack_depth) {
- $DB::stack[ $i ] &= ~1;
+ for my $i (0 .. $stack_depth) {
+ $stack[ $i ] &= ~1;
}
# And we are now no longer in single-step mode.
- $DB::single = 0;
+ $single = 0;
# If we simply returned at this point, we wouldn't get
# the trace info. Fall on through.
# return;
} ## end if ($runnonstop)
- elsif ($DB::ImmediateStop) {
+ elsif ($ImmediateStop) {
# We are supposed to stop here; XXX probably a break.
- $DB::ImmediateStop = 0; # We've processed it; turn it off
- $DB::signal = 1; # Simulate an interrupt to force
+ $ImmediateStop = 0; # We've processed it; turn it off
+ $signal = 1; # Simulate an interrupt to force
# us into the command loop
}
} ## end if ($single and not $second_time...
# If we're in single-step mode, or an interrupt (real or fake)
# has occurred, turn off non-stop mode.
- $DB::runnonstop = 0 if $DB::single or $DB::signal;
+ $runnonstop = 0 if $single or $signal;
return;
}
{
my $self = shift;
- if ( $DB::trace & 2 ) {
- for my $n (0 .. $#DB::to_watch) {
- $DB::evalarg = $DB::to_watch[$n];
- local $DB::onetimeDump; # Tell DB::eval() to not output results
+ if ( $trace & 2 ) {
+ for my $n (0 .. $#to_watch) {
+ $evalarg = $to_watch[$n];
+ local $onetimeDump; # Tell DB::eval() to not output results
# Fix context DB::eval() wants to return an array, but
# we need a scalar here.
$val = ( ( defined $val ) ? "'$val'" : 'undef' );
# Did it change?
- if ( $val ne $DB::old_watch[$n] ) {
+ if ( $val ne $old_watch[$n] ) {
# Yep! Show the difference, and fake an interrupt.
- $DB::signal = 1;
- print {$DB::OUT} <<EOP;
-Watchpoint $n:\t$DB::to_watch[$n] changed:
- old value:\t$DB::old_watch[$n]
+ $signal = 1;
+ print {$OUT} <<EOP;
+Watchpoint $n:\t$to_watch[$n] changed:
+ old value:\t$old_watch[$n]
new value:\t$val
EOP
- $DB::old_watch[$n] = $val;
+ $old_watch[$n] = $val;
} ## end if ($val ne $old_watch...
} ## end for my $n (0 ..
} ## end if ($trace & 2)
return;
}
-sub _my_print_lineinfo
-{
- my ($self, $i, $incr_pos) = @_;
+sub _my_print_lineinfo
+{
+ my ($self, $i, $incr_pos) = @_;
+
+ 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);
+ }
+}
+
+sub _curr_line {
+ return $DB::dbline[$line];
+}
+
+sub _is_full {
+ my ($self, $letter) = @_;
+
+ return ($DB::cmd eq $letter);
+}
+
+sub _DB__grab_control
+{
+ my $self = shift;
+
+ # Yes, grab control.
+ if ($slave_editor) {
+
+ # Tell the editor to update its position.
+ $self->position("\032\032${DB::filename}:$line:0\n");
+ DB::print_lineinfo($self->position());
+ }
+
+=pod
+
+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.
+
+=cut
+
+ elsif ( $DB::package eq 'DB::fake' ) {
+
+ # Fallen off the end already.
+ if (!$DB::term) {
+ DB::setterm();
+ }
+
+ 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
+
+ # Set the DB::eval context appropriately.
+ $DB::package = 'main';
+ $DB::usercontext = DB::_calc_usercontext($DB::package);
+ } ## end elsif ($package eq 'DB::fake')
+
+=pod
+
+If the program hasn't finished executing, we scan forward to the
+next executable line, print that out, build the prompt from the file and line
+number information, and print that.
+
+=cut
+
+ else {
+
+
+ # Still somewhere in the midst of execution. Set up the
+ # debugger prompt.
+ $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");
+ }
+ else {
+ $self->infix("):\t");
+ $self->position(
+ $self->prefix . $line. $self->infix
+ . $self->_curr_line . $self->after
+ );
+ }
+
+ # Print current line info, indenting if necessary.
+ $self->_my_print_lineinfo($line, $self->position);
+
+ my $i;
+ my $line_i = sub { return $DB::dbline[$i]; };
+
+ # 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_t_command {
+ my $self = shift;
+
+ my $levels = $self->cmd_args();
+
+ if ((!length($levels)) or ($levels !~ /\D/)) {
+ $trace ^= 1;
+ local $\ = '';
+ $DB::trace_to_depth = $levels ? $stack_depth + $levels : 1E9;
+ print {$OUT} "Trace = "
+ . ( ( $trace & 1 )
+ ? ( $levels ? "on (to level $DB::trace_to_depth)" : "on" )
+ : "off" ) . "\n";
+ next CMD;
+ }
+
+ return;
+}
+
+
+sub _handle_S_command {
+ my $self = shift;
+
+ 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;
+
+ # Need to make these sane here.
+ local $\ = '';
+ local $, = '';
+
+ # Search through the debugger's magical hash of subs.
+ # If $nocheck is true, just print the sub name.
+ # Otherwise, check it against the pattern. We then use
+ # the XOR trick to reverse the condition as required.
+ foreach $subname ( sort( keys %sub ) ) {
+ if ( $Snocheck or $Srev ^ ( $subname =~ /$Spatt/ ) ) {
+ print $OUT $subname, "\n";
+ }
+ }
+ next CMD;
+ }
+
+ return;
+}
+
+sub _handle_V_command_and_X_command {
+ my $self = shift;
+
+ $DB::cmd =~ s/^X\b/V $DB::package/;
+
+ # Bare V commands get the currently-being-debugged package
+ # added.
+ if ($self->_is_full('V')) {
+ $DB::cmd = "V $DB::package";
+ }
+
+ # V - show variables in package.
+ if (my ($new_packname, $new_vars_str) =
+ $DB::cmd =~ /\AV\b\s*(\S+)\s*(.*)/) {
+
+ # Save the currently selected filehandle and
+ # force output to debugger's filehandle (dumpvar
+ # just does "print" for output).
+ my $savout = select($OUT);
+
+ # Grab package name and variables to dump.
+ $packname = $new_packname;
+ my @vars = split( ' ', $new_vars_str );
+
+ # If main::dumpvar isn't here, get it.
+ do 'dumpvar.pl' || die $@ unless defined &main::dumpvar;
+ if ( defined &main::dumpvar ) {
+
+ # We got it. Turn off subroutine entry/exit messages
+ # for the moment, along with return values.
+ local $frame = 0;
+ local $doret = -2;
+
+ # must detect sigpipe failures - not catching
+ # then will cause the debugger to die.
+ eval {
+ main::dumpvar(
+ $packname,
+ defined $option{dumpDepth}
+ ? $option{dumpDepth}
+ : -1, # assume -1 unless specified
+ @vars
+ );
+ };
+
+ # The die doesn't need to include the $@, because
+ # it will automatically get propagated for us.
+ if ($@) {
+ die unless $@ =~ /dumpvar print failed/;
+ }
+ } ## end if (defined &main::dumpvar)
+ else {
+
+ # Couldn't load dumpvar.
+ print $OUT "dumpvar.pl not available.\n";
+ }
+
+ # Restore the output filehandle, and go round again.
+ select($savout);
+ next CMD;
+ }
+
+ return;
+}
+
+sub _handle_dash_command {
+ my $self = shift;
+
+ if ($self->_is_full('-')) {
+
+ # back up by a window; go to 1 if back too far.
+ $start -= $incr + $window + 1;
+ $start = 1 if $start <= 0;
+ $incr = $window - 1;
+
+ # Generate and execute a "l +" command (handled below).
+ $DB::cmd = 'l ' . ($start) . '+';
+ redo CMD;
+ }
+ return;
+}
+
+sub _n_or_s_commands_generic {
+ my ($self, $new_val) = @_;
+ # n - next
+ next CMD if DB::_DB__is_finished();
+
+ # Single step, but don't enter subs.
+ $single = $new_val;
+
+ # Save for empty command (repeat last).
+ $laststep = $DB::cmd;
+ last CMD;
+}
+
+sub _n_or_s {
+ my ($self, $letter, $new_val) = @_;
+
+ 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);
+ }
+
+ return;
+}
+
+sub _handle_n_command {
+ my $self = shift;
+
+ return $self->_n_or_s('n', 2);
+}
+
+sub _handle_s_command {
+ my $self = shift;
+
+ return $self->_n_or_s('s', 1);
+}
+
+sub _handle_r_command {
+ my $self = shift;
+
+ # r - return from the current subroutine.
+ if ($self->_is_full('r')) {
+
+ # Can't do anything if the program's over.
+ next CMD if DB::_DB__is_finished();
+
+ # Turn on stack trace.
+ $stack[$stack_depth] |= 1;
+
+ # Print return value unless the stack is empty.
+ $doret = $option{PrintRet} ? $stack_depth - 1 : -2;
+ last CMD;
+ }
+
+ return;
+}
+
+sub _handle_T_command {
+ my $self = shift;
+
+ if ($self->_is_full('T')) {
+ DB::print_trace( $OUT, 1 ); # skip DB
+ next CMD;
+ }
+
+ return;
+}
+
+sub _handle_w_command {
+ my $self = shift;
+
+ DB::cmd_w( 'w', $self->cmd_args() );
+ next CMD;
+
+ return;
+}
+
+sub _handle_W_command {
+ my $self = shift;
+
+ if (my $arg = $self->cmd_args) {
+ DB::cmd_W( 'W', $arg );
+ next CMD;
+ }
+
+ return;
+}
+
+sub _handle_rc_recall_command {
+ my $self = shift;
+
+ # $rc - recall command.
+ if (my ($minus, $arg) = $DB::cmd =~ m#\A$rc+\s*(-)?(\d+)?\z#) {
+
+ # 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 _handle_rc_search_history_command {
+ my $self = shift;
+
+ # $rc pattern $rc - find a command in the history.
+ if (my ($arg) = $DB::cmd =~ /\A$rc([^$rc].*)\z/) {
+
+ # Create the pattern to use.
+ my $pat = "^$arg";
+ $self->pat($pat);
+
+ # Toss off last entry if length is >1 (and it always is).
+ pop(@hist) if length($DB::cmd) > 1;
+
+ my $i;
+
+ # Look backward through the history.
+ SEARCH_HIST:
+ for ( $i = $#hist ; $i ; --$i ) {
+ # Stop if we find it.
+ last SEARCH_HIST if $hist[$i] =~ /$pat/;
+ }
+
+ if ( !$i ) {
+
+ # Never found it.
+ print $OUT "No such command!\n\n";
+ next CMD;
+ }
+
+ # Found it. Put it in the buffer, print it, and process it.
+ $DB::cmd = $hist[$i];
+ print $OUT $DB::cmd, "\n";
+ redo CMD;
+ }
+
+ return;
+}
+
+sub _handle_H_command {
+ my $self = shift;
+
+ if ($self->cmd_args =~ m#\A\*#) {
+ @hist = @truehist = ();
+ print $OUT "History cleansed\n";
+ next CMD;
+ }
+
+ if (my ($num) = $self->cmd_args =~ /\A(?:-(\d+))?/) {
+
+ # Anything other than negative numbers is ignored by
+ # the (incorrect) pattern, so this test does nothing.
+ $end = $num ? ( $#hist - $num ) : 0;
+
+ # Set to the minimum if less than zero.
+ $hist = 0 if $hist < 0;
+
+ # Start at the end of the array.
+ # Stay in while we're still above the ending value.
+ # Tick back by one each time around the loop.
+ my $i;
+
+ for ( $i = $#hist ; $i > $end ; $i-- ) {
+
+ # Print the command unless it has no arguments.
+ print $OUT "$i: ", $hist[$i], "\n"
+ unless $hist[$i] =~ /^.?$/;
+ }
+
+ next CMD;
+ }
+
+ return;
+}
+
+sub _handle_doc_command {
+ my $self = shift;
+
+ # man, perldoc, doc - show manual pages.
+ if (my ($man_page)
+ = $DB::cmd =~ /\A(?:man|(?:perl)?doc)\b(?:\s+([^(]*))?\z/) {
+ runman($man_page);
+ next CMD;
+ }
+
+ return;
+}
+
+sub _handle_p_command {
+ my $self = shift;
+
+ 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 /;
+ }
+
+ return;
+}
+
+sub _handle_equal_sign_command {
+ my $self = shift;
+
+ if ($DB::cmd =~ s/\A=\s*//) {
+ my @keys;
+ if ( length $DB::cmd == 0 ) {
+
+ # No args, get current aliases.
+ @keys = sort keys %alias;
+ }
+ elsif ( my ( $k, $v ) = ( $DB::cmd =~ /^(\S+)\s+(\S.*)/ ) ) {
+
+ # Creating a new alias. $k is alias name, $v is
+ # alias value.
+
+ # can't use $_ or kill //g state
+ for my $x ( $k, $v ) {
+
+ # Escape "alarm" characters.
+ $x =~ s/\a/\\a/g;
+ }
+
+ # Substitute key for value, using alarm chars
+ # as separators (which is why we escaped them in
+ # the command).
+ $alias{$k} = "s\a$k\a$v\a";
+
+ # Turn off standard warn and die behavior.
+ local $SIG{__DIE__};
+ local $SIG{__WARN__};
+
+ # Is it valid Perl?
+ unless ( eval "sub { s\a$k\a$v\a }; 1" ) {
+
+ # Nope. Bad alias. Say so and get out.
+ print $OUT "Can't alias $k to $v: $@\n";
+ delete $alias{$k};
+ next CMD;
+ }
+
+ # We'll only list the new one.
+ @keys = ($k);
+ } ## end elsif (my ($k, $v) = ($DB::cmd...
+
+ # The argument is the alias to list.
+ else {
+ @keys = ($DB::cmd);
+ }
+
+ # List aliases.
+ for my $k (@keys) {
+
+ # Messy metaquoting: Trim the substitution code off.
+ # We use control-G as the delimiter because it's not
+ # likely to appear in the alias.
+ if ( ( my $v = $alias{$k} ) =~ s\as\a$k\a(.*)\a$\a1\a ) {
+
+ # Print the alias.
+ print $OUT "$k\t= $1\n";
+ }
+ elsif ( defined $alias{$k} ) {
+
+ # Couldn't trim it off; just print the alias code.
+ print $OUT "$k\t$alias{$k}\n";
+ }
+ else {
+
+ # No such, dude.
+ print "No alias for $k\n";
+ }
+ } ## end for my $k (@keys)
+ next CMD;
+ }
+
+ return;
+}
+
+sub _handle_source_command {
+ my $self = shift;
- if ($DB::frame) {
- # Print it indented if tracing is on.
- DB::print_lineinfo( ' ' x $DB::stack_depth,
- "$i:\t$DB::dbline[$i]" . $self->after );
- }
- else {
- DB::depth_print_lineinfo($self->explicit_stop, $incr_pos);
+ # 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 {
+
+ # Couldn't open it.
+ DB::_db_warn("Can't execute '$sourced_fn': $!\n");
+ }
+ next CMD;
}
-}
-sub _curr_line {
- return $DB::dbline[$DB::line];
+ return;
}
-sub _DB__grab_control
-{
+sub _handle_enable_disable_commands {
my $self = shift;
- # Yes, grab control.
- if ($DB::slave_editor) {
+ my $which_cmd = $self->cmd_verb;
+ my $position = $self->cmd_args;
- # Tell the editor to update its position.
- $self->position("\032\032${DB::filename}:${DB::line}:0\n");
- DB::print_lineinfo($self->position());
- }
+ 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");
+ }
-=pod
+ 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");
+ }
+ }
-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.
+ next CMD;
+ }
-=cut
+ return;
+}
- elsif ( $DB::package eq 'DB::fake' ) {
+sub _handle_save_command {
+ my $self = shift;
- # Fallen off the end already.
- if (!$DB::term) {
- DB::setterm();
+ if (my $new_fn = $self->cmd_args) {
+ my $filename = $new_fn || '.perl5dbrc'; # default?
+ if ( open my $fh, '>', $filename ) {
+
+ # 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;
+ }
- 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
+ return;
+}
- # Set the DB::eval context appropriately.
- $DB::package = 'main';
- $DB::usercontext = DB::_calc_usercontext($DB::package);
- } ## end elsif ($package eq 'DB::fake')
+sub _n_or_s_and_arg_commands_generic {
+ my ($self, $letter, $new_val) = @_;
-=pod
+ # 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;
+ }
-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.
+ return;
+}
-=cut
+sub _handle_sh_command {
+ my $self = shift;
- else {
+ # $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;
+ }
+ }
+}
- # 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)
+sub _handle_x_command {
+ my $self = shift;
- $self->prefix($DB::sub =~ /::/ ? "" : ($DB::package . '::'));
- $self->append_to_prefix( "$DB::sub(${DB::filename}:" );
- $self->after( $self->_curr_line =~ /\n$/ ? '' : "\n" );
+ if ($DB::cmd =~ s#\Ax\b# #) { # Remainder gets done by DB::eval()
+ $onetimeDump = 'dump'; # main::dumpvar shows the output
- # Break up the prompt if it's really long.
- if ( length($self->prefix()) > 30 ) {
- $self->position($self->prefix . "$DB::line):\n$DB::line:\t" . $self->_curr_line . $self->after);
- $self->prefix("");
- $self->infix(":\t");
- }
- else {
- $self->infix("):\t");
- $self->position(
- $self->prefix . $DB::line. $self->infix
- . $self->_curr_line . $self->after
- );
+ # handle special "x 3 blah" syntax XXX propagate
+ # doc back to special variables.
+ if ( $DB::cmd =~ s#\A\s*(\d+)(?=\s)# #) {
+ $onetimedumpDepth = $1;
}
+ }
- # Print current line info, indenting if necessary.
- $self->_my_print_lineinfo($DB::line, $self->position);
+ return;
+}
- my $i;
- my $line_i = sub { return $DB::dbline[$i]; };
+sub _handle_q_command {
+ my $self = shift;
- # Scan forward, stopping at either the end or the next
- # unbreakable line.
- for ( $i = $DB::line + 1 ; $i <= $DB::max && $line_i->() == 0 ; ++$i )
- { #{ vi
+ if ($self->_is_full('q')) {
+ $fall_off_end = 1;
+ DB::clean_ENV();
+ exit $?;
+ }
- # Drop out on null statements, block closers, and comments.
- last if $line_i->() =~ /^\s*[\;\}\#\n]/;
+ return;
+}
- # Drop out if the user interrupted us.
- last if $DB::signal;
+sub _handle_cmd_wrapper_commands {
+ my $self = shift;
- # Append a newline if the line doesn't have one. Can happen
- # in eval'ed text, for instance.
- $self->after( $line_i->() =~ /\n$/ ? '' : "\n" );
+ DB::cmd_wrapper( $self->cmd_verb, $self->cmd_args, $line );
+ next CMD;
+}
- # 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)
+sub _handle_special_char_cmd_wrapper_commands {
+ my $self = shift;
+
+ # All of these commands were remapped in perl 5.8.0;
+ # we send them off to the secondary dispatcher (see below).
+ if (my ($cmd_letter, $my_arg) = $DB::cmd =~ /\A([<>\{]{1,2})\s*(.*)/so) {
+ DB::cmd_wrapper( $cmd_letter, $my_arg, $line );
+ next CMD;
+ }
return;
}
# 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 _print_frame_message {
+ my ($al) = @_;
+
+ if ($frame) {
+ if ($frame & 4) { # Extended frame entry message
+ _indent_print_line_info(-1, "in ");
+
+ # Why -1? But it works! :-(
+ # Because print_trace will call add 1 to it and then call
+ # dump_trace; this results in our skipping -1+1 = 0 stack frames
+ # in dump_trace.
+ #
+ # Now it's 0 because we extracted a function.
+ print_trace( $LINEINFO, 0, 1, 1, "$sub$al" );
+ }
+ else {
+ _indent_print_line_info(-1, "entering $sub$al\n" );
+ }
+ }
+
+ return;
+}
+
sub DB::sub {
- # Do not use a regex in this subroutine -> results in corrupted memory
- # See: [perl #66110]
+ # Do not use a regex in this subroutine -> results in corrupted memory
+ # See: [perl #66110]
- # lock ourselves under threads
- lock($DBGR);
+ # lock ourselves under threads
+ lock($DBGR);
# Whether or not the autoloader was running, a scalar to put the
# sub's return value in (if needed), and an array to put the sub's
# return value in (if needed).
my ( $al, $ret, @ret ) = "";
- if ($sub eq 'threads::new' && $ENV{PERL5DB_THREADED}) {
- print "creating new thread\n";
- }
+ if ($sub eq 'threads::new' && $ENV{PERL5DB_THREADED}) {
+ print "creating new thread\n";
+ }
# If the last ten characters are '::AUTOLOAD', note we've traced
# into AUTOLOAD for $sub.
$single |= 4 if $stack_depth == $deep;
# If frame messages are on ...
- (
- $frame & 4 # Extended frame entry message
- ? (
- print_lineinfo( ' ' x ( $stack_depth - 1 ), "in " ),
- # Why -1? But it works! :-(
- # Because print_trace will call add 1 to it and then call
- # dump_trace; this results in our skipping -1+1 = 0 stack frames
- # in dump_trace.
- print_trace( $LINEINFO, -1, 1, 1, "$sub$al" )
- )
- : print_lineinfo( ' ' x ( $stack_depth - 1 ), "entering $sub$al\n" )
+ _print_frame_message($al);
+ # standard frame entry message
- # standard frame entry message
- )
- if $frame;
+ my $print_exit_msg = sub {
+ # Check for exit trace messages...
+ if ($frame & 2)
+ {
+ if ($frame & 4) # Extended exit message
+ {
+ _indent_print_line_info(0, "out ");
+ print_trace( $LINEINFO, 0, 1, 1, "$sub$al" );
+ }
+ else
+ {
+ _indent_print_line_info(0, "exited $sub$al\n" );
+ }
+ }
+ return;
+ };
# Determine the sub's return type, and capture appropriately.
if (wantarray) {
# Pop the single-step value back off the stack.
$single |= $stack[ $stack_depth-- ];
- # Check for exit trace messages...
- (
- $frame & 4 # Extended exit message
- ? (
- print_lineinfo( ' ' x $stack_depth, "out " ),
- print_trace( $LINEINFO, -1, 1, 1, "$sub$al" )
- )
- : print_lineinfo( ' ' x $stack_depth, "exited $sub$al\n" )
-
- # Standard exit message
- )
- if $frame & 2;
+ $print_exit_msg->();
# Print the return info if we need to.
if ( $doret eq $stack_depth or $frame & 16 ) {
my $fh = ( $doret eq $stack_depth ? $OUT : $LINEINFO );
# Indent if we're printing because of $frame tracing.
- print $fh ' ' x $stack_depth if $frame & 16;
+ if ($frame & 16)
+ {
+ print {$fh} ' ' x $stack_depth;
+ }
# Print the return value.
- print $fh "list context return from $sub:\n";
+ print {$fh} "list context return from $sub:\n";
dumpit( $fh, \@ret );
# And don't print it again.
# Scalar context.
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;
- }
+ 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;
+ }
# Pop the single-step value off the stack.
$single |= $stack[ $stack_depth-- ];
# If we're doing exit messages...
- (
- $frame & 4 # Extended messages
- ? (
- print_lineinfo( ' ' x $stack_depth, "out " ),
- print_trace( $LINEINFO, -1, 1, 1, "$sub$al" )
- )
- : print_lineinfo( ' ' x $stack_depth, "exited $sub$al\n" )
-
- # Standard messages
- )
- if $frame & 2;
+ $print_exit_msg->();
# If we are supposed to show the return value... same as before.
if ( $doret eq $stack_depth or $frame & 16 and defined wantarray ) {
no strict 'refs';
- # lock ourselves under threads
- lock($DBGR);
+ # lock ourselves under threads
+ lock($DBGR);
# Whether or not the autoloader was running, a scalar to put the
# sub's return value in (if needed), and an array to put the sub's
# return value in (if needed).
my ( $al, $ret, @ret ) = "";
- if ($sub =~ /^threads::new$/ && $ENV{PERL5DB_THREADED}) {
- print "creating new thread\n";
- }
+ if ($sub =~ /^threads::new$/ && $ENV{PERL5DB_THREADED}) {
+ print "creating new thread\n";
+ }
# If the last ten characters are C'::AUTOLOAD', note we've traced
# into AUTOLOAD for $sub.
$single |= 4 if $stack_depth == $deep;
# If frame messages are on ...
- (
- $frame & 4 # Extended frame entry message
- ? (
- print_lineinfo( ' ' x ( $stack_depth - 1 ), "in " ),
-
- # Why -1? But it works! :-(
- # Because print_trace will call add 1 to it and then call
- # dump_trace; this results in our skipping -1+1 = 0 stack frames
- # in dump_trace.
- print_trace( $LINEINFO, -1, 1, 1, "$sub$al" )
- )
- : print_lineinfo( ' ' x ( $stack_depth - 1 ), "entering $sub$al\n" )
-
- # standard frame entry message
- )
- if $frame;
+ _print_frame_message($al);
# Pop the single-step value back off the stack.
$single |= $stack[ $stack_depth-- ];
# default to the older version of the command.
my $call = 'cmd_'
. ( $set{$CommandSet}{$cmd}
- || ( $cmd =~ /^[<>{]+/o ? 'prepost' : $cmd ) );
+ || ( $cmd =~ /\A[<>{]+/o ? 'prepost' : $cmd ) );
# Call the command subroutine, call it by name.
return __PACKAGE__->can($call)->( $cmd, $line, $dblineno );
my $dbline = shift;
# If it's dot (here), or not all digits, use the current line.
- $line =~ s/^(\.|(?:[^\d]))/$dbline/;
+ $line =~ s/\A\./$dbline/;
# Should be a line number followed by an expression.
- if ( $line =~ /^\s*(\d*)\s*(\S.+)/ ) {
- my ( $lineno, $expr ) = ( $1, $2 );
+ if ( my ($lineno, $expr) = $line =~ /^\s*(\d*)\s*(\S.+)/ ) {
+
+ if (! length($lineno)) {
+ $lineno = $dbline;
+ }
# If we have an expression ...
if ( length $expr ) {
=cut
sub cmd_b_sub {
- my ( $subname, $cond ) = @_;
-
- # Add always-true condition if we have none.
- $cond = 1 unless @_ >= 2;
+ my $subname = shift;
+ my $cond = @_ ? shift : 1;
# If the subname isn't a code reference, qualify it so that
# break_subroutine() will work right.
- unless ( ref $subname eq 'CODE' ) {
+ if ( ref($subname) ne 'CODE' ) {
- # Not Perl4.
- $subname =~ s/\'/::/g;
+ # Not Perl 4.
+ $subname =~ s/'/::/g;
my $s = $subname;
# Put it in this package unless it's already qualified.
- $subname = "${package}::" . $subname
- unless $subname =~ /::/;
+ if ($subname !~ /::/)
+ {
+ $subname = $package . '::' . $subname;
+ };
# Requalify it into CORE::GLOBAL if qualifying it into this
# package resulted in its not being defined, but only do so
# if it really is in CORE::GLOBAL.
- $subname = "CORE::GLOBAL::$s"
- if not defined &$subname
- and $s !~ /::/
- and defined &{"CORE::GLOBAL::$s"};
+ my $core_name = "CORE::GLOBAL::$s";
+ if ((!defined(&$subname))
+ and ($s !~ /::/)
+ and (defined &{$core_name}))
+ {
+ $subname = $core_name;
+ }
# Put it in package 'main' if it has a leading ::.
- $subname = "main" . $subname if substr( $subname, 0, 2 ) eq "::";
-
- } ## end unless (ref $subname eq 'CODE')
+ if ($subname =~ /\A::/)
+ {
+ $subname = "main" . $subname;
+ }
+ } ## end if ( ref($subname) ne 'CODE' ) {
# Try to set the breakpoint.
if (not eval { break_subroutine( $subname, $cond ); 1 }) {
local $\ = '';
- print $OUT $@ and return;
+ print {$OUT} $@;
+ return;
}
return;
Display the current thread id:
- e
+ e
This could be how (when implemented) to send commands to this thread id (e cmd)
or that thread id (e tid cmd).
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";
- }
+ unless (exists($INC{'threads.pm'})) {
+ print "threads not loaded($ENV{PERL5DB_THREADED})
+ please run the debugger with PERL5DB_THREADED=1 set in the environment\n";
+ } else {
+ my $tid = threads->tid;
+ print "thread id: $tid\n";
+ }
} ## end sub cmd_e
=head3 C<cmd_E> - list of thread ids
Display the list of available thread ids:
- E
+ E
This could be used (when implemented) to send commands to all threads (E cmd).
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";
- }
+ 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)
=cut
+sub _min {
+ my $min = shift;
+ foreach my $v (@_) {
+ if ($v < $min) {
+ $v = $min;
+ }
+ }
+ return $min;
+}
+
+sub _minify_to_max {
+ my $ref = shift;
+
+ $$ref = _min($$ref, $max);
+
+ return;
+}
+
sub cmd_l {
my $current_line = $line;
my $cmd = shift;
# If the line is '$something', assume this is a scalar containing a
# line number.
- if ( $line =~ /^(\$.*)/s ) {
+ # Set up for DB::eval() - evaluate in *user* context.
+ if ( ($evalarg) = $line =~ /\A(\$.*)/s ) {
- # Set up for DB::eval() - evaluate in *user* context.
- $evalarg = $1;
- # $evalarg = $2;
my ($s) = DB::eval();
# Ooops. Bad scalar.
$line = "$1 $s";
# Call self recursively to really do the command.
- cmd_l( 'l', $s );
+ return cmd_l( 'l', $s );
} ## end if ($line =~ /^(\$.*)/s)
# l name. Try to find a sub by that name.
# If we're not in that file, switch over to it.
if ( $file ne $filename ) {
- print $OUT "Switching to file '$file'.\n"
- unless $slave_editor;
+ if (! $slave_editor) {
+ print {$OUT} "Switching to file '$file'.\n";
+ }
# Switch debugger's magic structures.
*dbline = $main::{ '_<' . $file };
# Call self recursively to list the range.
$line = $subrange;
- cmd_l( 'l', $subrange );
+ return cmd_l( 'l', $subrange );
} ## end if ($subrange)
# Couldn't find it.
else {
- print $OUT "Subroutine $subname not found.\n";
+ print {$OUT} "Subroutine $subname not found.\n";
+ return;
}
} ## end elsif ($line =~ /^([\':A-Za-z_][\':\w]*(\[.*\])?)/s)
$line = $start . '-' . ( $start + $incr );
# Recurse to do it.
- cmd_l( 'l', $line );
+ return cmd_l( 'l', $line );
}
# l [start]+number_of_lines
# Increment for list. Use window size if not specified.
# (Allows 'l +' to work.)
- $incr = $new_incr;
- $incr = $window - 1 unless $incr;
+ $incr = $new_incr || ($window - 1);
# Create a line range we'll understand, and recurse to do it.
$line = $start . '-' . ( $start + $incr );
- cmd_l( 'l', $line );
+ return cmd_l( 'l', $line );
} ## end elsif ($line =~ /^(\d*)\+(\d*)$/)
# l start-stop or l start,stop
my $end = ( !defined $2 ) ? $max : ( $4 ? $4 : $2 );
# Go on to the end, and then stop.
- $end = $max if $end > $max;
+ _minify_to_max(\$end);
# Determine start line.
my $i = $2;
# - whether a line has a break or not
# - whether a line has an action or not
else {
+ I_TO_END:
for ( ; $i <= $end ; $i++ ) {
# Check for breakpoints and actions.
my ( $stop, $action );
- ( $stop, $action ) = split( /\0/, $dbline{$i} )
- if $dbline{$i};
+ if ($dbline{$i}) {
+ ( $stop, $action ) = split( /\0/, $dbline{$i} );
+ }
# ==> if this is the current line in execution,
# : if it's breakable.
$arrow .= 'a' if $action;
# Print the line.
- print $OUT "$i$arrow\t", $dbline[$i];
+ print {$OUT} "$i$arrow\t", $dbline[$i];
# Move on to the next line. Drop out on an interrupt.
- $i++, last if $signal;
+ if ($signal) {
+ $i++;
+ last I_TO_END;
+ }
} ## end for (; $i <= $end ; $i++)
# Line the prompt up; print a newline if the last line listed
# didn't have a newline.
- print $OUT "\n" unless $dbline[ $i - 1 ] =~ /\n$/;
+ if ($dbline[ $i - 1 ] !~ /\n\z/) {
+ print {$OUT} "\n";
+ }
} ## end else [ if ($slave_editor)
# Save the point we last listed to in case another relative 'l'
# command is desired. Don't let it run off the end.
$start = $i;
- $start = $max if $start > $max;
+ _minify_to_max(\$start);
+
+ return;
} ## end elsif ($line =~ /^((-?[\d\$\.]+)([-,]([\d\$\.]+))?)?/)
} ## end sub cmd_l
# If no argument, list everything. Pre-5.8.0 version always lists
# everything
my $arg = shift || 'abw';
- $arg = 'abw' unless $CommandSet eq '580'; # sigh...
+ if ($CommandSet ne '580')
+ {
+ $arg = 'abw';
+ }
# See what is wanted.
my $action_wanted = ( $arg =~ /a/ ) ? 1 : 0;
# Nonblank. Try to parse and process.
if ( $opt =~ /^(\S.*)/ ) {
- &parse_options($1);
+ parse_options($1);
}
# Blank. List the current option settings.
else {
for (@options) {
- &dump_option($_);
+ dump_option($_);
}
}
} ## end sub cmd_o
}
# If this is a subroutine, let postponed_sub() deal with it.
- return &postponed_sub unless ref \$_[0] eq 'GLOB';
+ if (ref(\$_[0]) ne 'GLOB') {
+ return postponed_sub(@_);
+ }
# Not a subroutine. Deal with the file.
local *dbline = shift;
my $v = shift;
my $maxdepth = shift || $option{dumpDepth};
$maxdepth = -1 unless defined $maxdepth; # -1 means infinite depth
- &main::dumpValue( $v, $maxdepth );
+ main::dumpValue( $v, $maxdepth );
} ## end if (defined &main::dumpValue)
# Oops, couldn't load dumpvar.pl.
$file = $file eq '-e' ? $file : "file '$file'" unless $short;
# Get the actual sub's name, and shorten to $maxtrace's requirement.
- $s = $sub[$i]{sub};
+ $s = $sub[$i]{'sub'};
$s = ( substr $s, 0, $maxtrace - 3 ) . '...' if length $s > $maxtrace;
# Short report uses trimmed file and sub names.
while ( $action =~ s/\\$// ) {
# We have a backslash on the end. Read more.
- $action .= &gets;
+ $action .= gets();
} ## end while ($action =~ s/\\$//)
# Return the assembled action.
=cut
sub gets {
- &readline("cont: ");
+ return DB::readline("cont: ");
}
-=head2 C<DB::system()> - handle calls to<system()> without messing up the debugger
+=head2 C<_db_system()> - handle calls to<system()> without messing up the debugger
The C<system()> function assumes that it can just go ahead and use STDIN and
STDOUT, but under the debugger, we want it to use the debugger's input and
outout filehandles.
-C<DB::system()> socks away the program's STDIN and STDOUT, and then substitutes
+C<_db_system()> socks away the program's STDIN and STDOUT, and then substitutes
the debugger's IN and OUT filehandles for them. It does the C<system()> call,
and then puts everything back again.
=cut
-sub system {
+sub _db_system {
# We save, change, then restore STDIN and STDOUT to avoid fork() since
# some non-Unix systems can do system() but have problems with fork().
- open( SAVEIN, "<&STDIN" ) || &warn("Can't save STDIN");
- open( SAVEOUT, ">&STDOUT" ) || &warn("Can't save STDOUT");
- open( STDIN, "<&IN" ) || &warn("Can't redirect STDIN");
- open( STDOUT, ">&OUT" ) || &warn("Can't redirect STDOUT");
+ 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" ) || &warn("Can't restore STDIN");
- open( STDOUT, ">&SAVEOUT" ) || &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 ) {
- &warn( "(Command exited ", ( $? >> 8 ), ")\n" );
+ db_warn( "(Command exited ", ( $? >> 8 ), ")\n" );
}
elsif ($?) {
- &warn(
+ db_warn(
"(Command died of SIG#",
( $? & 127 ),
( ( $? & 128 ) ? " -- core dumped" : "" ),
} ## end sub system
+*system = \&_db_system;
+
=head1 TTY MANAGEMENT
The subs here do some of the terminal management for multiple debuggers.
$term->MinLine(2);
- &load_hist();
+ load_hist();
if ( $term->Features->{setHistory} and "@hist" ne "?" ) {
$term->SetHistory(@hist);
sub os2_get_fork_TTY { # A simplification of the following (and works without):
local $\ = '';
( my $name = $0 ) =~ s,^.*[/\\],,s;
- my %opt = ( title => "Daughter Perl debugger $pids $name",
- ($rl ? (read_by_key => 1) : ()) );
+ my %opt = ( title => "Daughter Perl debugger $pids $name",
+ ($rl ? (read_by_key => 1) : ()) );
require OS2::Process;
my ($in, $out, $pid) = eval { OS2::Process::io_term(related => 0, %opt) }
or return;
return unless $version=$ENV{TERM_PROGRAM_VERSION};
foreach my $entry (@script_versions) {
- if ($version>=$entry->[0]) {
- $script=$entry->[1];
- last;
- }
+ if ($version>=$entry->[0]) {
+ $script=$entry->[1];
+ last;
+ }
}
return unless defined($script);
return unless open($pipe,'-|','/usr/bin/osascript','-e',$script);
# If we know how to get a new TTY, do it! $in will have
# the TTY name if get_fork_TTY works.
- my $in = &get_fork_TTY if defined &get_fork_TTY;
+ my $in = get_fork_TTY(@_) if defined &get_fork_TTY;
# It used to be that
$in = $fork_TTY if defined $fork_TTY; # Backward compatibility
=cut
-sub warn {
+sub _db_warn {
my ($msg) = join( "", @_ );
$msg .= ": $!\n" unless $msg =~ /\n$/;
local $\ = '';
print $OUT $msg;
} ## end sub warn
+*warn = \&_db_warn;
+
=head1 INITIALIZATION TTY SUPPORT
=head2 C<reset_IN_OUT>
# This term can't get a new tty now. Better luck later.
elsif ($term) {
- &warn("Too late to set IN/OUT filehandles, enabled on next 'R'!\n");
+ _db_warn("Too late to set IN/OUT filehandles, enabled on next 'R'!\n");
}
# Set the filehndles up as they were.
# Terminal doesn't support new TTY, or doesn't support readline.
# Can't do it now, try restarting.
- &warn("Too late to set TTY, enabled on next 'R'!\n") if $term and @_;
+ if ($term and @_) {
+ _db_warn("Too late to set TTY, enabled on next 'R'!\n");
+ }
# Useful if done through PERLDB_OPTS:
$console = $tty = shift if @_;
sub noTTY {
if ($term) {
- &warn("Too late to set noTTY, enabled on next 'R'!\n") if @_;
+ _db_warn("Too late to set noTTY, enabled on next 'R'!\n") if @_;
}
$notty = shift if @_;
$notty;
sub ReadLine {
if ($term) {
- &warn("Too late to set ReadLine, enabled on next 'R'!\n") if @_;
+ _db_warn("Too late to set ReadLine, enabled on next 'R'!\n") if @_;
}
$rl = shift if @_;
$rl;
sub RemotePort {
if ($term) {
- &warn("Too late to set RemotePort, enabled on next 'R'!\n") if @_;
+ _db_warn("Too late to set RemotePort, enabled on next 'R'!\n") if @_;
}
$remoteport = shift if @_;
$remoteport;
sub NonStop {
if ($term) {
- &warn("Too late to set up NonStop mode, enabled on next 'R'!\n")
+ _db_warn("Too late to set up NonStop mode, enabled on next 'R'!\n")
if @_;
}
$runnonstop = shift if @_;
sub DollarCaretP {
if ($term) {
- &warn("Some flag changes could not take effect until next 'R'!\n")
+ _db_warn("Some flag changes could not take effect until next 'R'!\n")
if @_;
}
$^P = parse_DollarCaretP_flags(shift) if @_;
if ( defined $term ) {
# We don't want to show warning backtraces, but we do want die() ones.
- local ( $warnLevel, $dieLevel ) = ( 0, 1 );
+ local $warnLevel = 0;
+ local $dieLevel = 1;
# No ornaments if the terminal doesn't support them.
- return '' unless $term->Features->{ornaments};
- eval { $term->ornaments(@_) } || '';
+ if (not $term->Features->{ornaments}) {
+ return '';
+ }
+
+ return (eval { $term->ornaments(@_) } || '');
}
# Use what was passed in if we can't determine it ourselves.
else {
$ornaments = shift;
+
+ return $ornaments;
}
+
} ## end sub ornaments
=head2 C<recallCommand>
}
# Build it into a printable version.
- $prc = $rc; # Copy it
+ $prc = $rc; # Copy it
$prc =~ s/\\b$//; # Remove trailing \b
$prc =~ s/\\(.)/$1/g; # Remove escapes
- $prc; # Return the printable version
+ return $prc; # Return the printable version
} ## end sub recallCommand
=head2 C<LineInfo> - where the line number information goes
# If this is a pipe, the stream points to a slave editor.
$slave_editor = ( $stream =~ /^\|/ );
+ my $new_lineinfo_fh;
# Open it up and unbuffer it.
- open( LINEINFO, $stream ) || &warn("Cannot open '$stream' for write");
- $LINEINFO = \*LINEINFO;
+ open ($new_lineinfo_fh , $stream )
+ or _db_warn("Cannot open '$stream' for write");
+ $LINEINFO = $new_lineinfo_fh;
$LINEINFO->autoflush(1);
}
local $Carp::CarpLevel = 2; # mydie + confess
# Tell us all about it.
- &warn( Carp::longmess("Signal @_") );
+ _db_warn( Carp::longmess("Signal @_") );
}
# No Carp. Tell us about the signal as best we can.
# Use the debugger's own special way of printing warnings to print
# the stack trace message.
- &warn($mess);
+ _db_warn($mess);
} ## end sub dbwarn
=head2 C<dbdie>
local $doret = -2;
local $SIG{__DIE__} = '';
local $SIG{__WARN__} = '';
- my $i = 0;
- my $ineval = 0;
- my $sub;
if ( $dieLevel > 2 ) {
local $SIG{__WARN__} = \&dbwarn;
- &warn(@_); # Yell no matter what
+ _db_warn(@_); # Yell no matter what
return;
}
if ( $dieLevel < 2 ) {
# Extract from all the symbols in this class.
my $class_ref = do { no strict "refs"; \%{$class . '::'} };
while (my ($name, $glob) = each %$class_ref) {
- # references directly in the symbol table are Proxy Constant
- # Subroutines, and are by their very nature defined
- # Otherwise, check if the thing is a typeglob, and if it is, it decays
- # to a subroutine reference, which can be tested by defined.
- # $glob might also be the value -1 (from sub foo;)
- # or (say) '$$' (from sub foo ($$);)
- # \$glob will be SCALAR in both cases.
- if ((ref $glob || ($glob && ref \$glob eq 'GLOB' && defined &$glob))
- && !$seen{$name}++) {
- push @to_print, "$prepend$name\n";
- }
+ # references directly in the symbol table are Proxy Constant
+ # Subroutines, and are by their very nature defined
+ # Otherwise, check if the thing is a typeglob, and if it is, it decays
+ # to a subroutine reference, which can be tested by defined.
+ # $glob might also be the value -1 (from sub foo;)
+ # or (say) '$$' (from sub foo ($$);)
+ # \$glob will be SCALAR in both cases.
+ if ((ref $glob || ($glob && ref \$glob eq 'GLOB' && defined &$glob))
+ && !$seen{$name}++) {
+ push @to_print, "$prepend$name\n";
+ }
}
{
- local $\ = '';
- local $, = '';
- print $DB::OUT $_ foreach sort @to_print;
+ local $\ = '';
+ local $, = '';
+ print $DB::OUT $_ foreach sort @to_print;
}
# If the $crawl_upward argument is false, just quit here.
=head2 C<runman> - run the appropriate command to show documentation
Accepts a man page name; runs the appropriate command to display it (set up
-during debugger initialization). Uses C<DB::system> to avoid mucking up the
+during debugger initialization). Uses C<_db_system()> to avoid mucking up the
program's STDIN and STDOUT.
=cut
apio
api
artistic
- beos
book
boot
bot
dsc
ebcdic
embed
- epoc
faq1
faq2
faq3
sub runman {
my $page = shift;
unless ($page) {
- &system("$doccmd $doccmd");
+ _db_system("$doccmd $doccmd");
return;
}
# this way user can override, like with $doccmd="man -Mwhatever"
# or even just "man " to disable the path check.
- unless ( $doccmd eq 'man' ) {
- &system("$doccmd $page");
+ if ( $doccmd ne 'man' ) {
+ _db_system("$doccmd $page");
return;
}
my @temp = @truehist; # store
push(@DB::typeahead, @truehist); # saved
@truehist = @hist = (); # flush
- @args = &restart(); # setup
- &get_list("PERLDB_HIST"); # clean
- &set_list("PERLDB_HIST", @temp); # reset
+ @args = restart(); # setup
+ get_list("PERLDB_HIST"); # clean
+ set_list("PERLDB_HIST", @temp); # reset
}
return @args;
}
# Do not stop in at_exit() and destructors on exit:
if ($fall_off_end or $runnonstop) {
- &save_hist();
+ save_hist();
} else {
$DB::single = 1;
DB::fake::at_exit();
if ( $cmd =~ /^load\b\s*(.*)/ ) {
my $file = $1;
$file =~ s/\s+$//;
- &cmd_b_load($file);
+ cmd_b_load($file);
}
# b compile|postpone <some sub> [<condition>]
elsif ( $cmd =~ /^([':A-Za-z_][':\w]*(?:\[.*\])?)\s*(.*)/ ) {
my $subname = $1;
my $cond = length $2 ? $2 : '1';
- &cmd_b_sub( $subname, $cond );
+ cmd_b_sub( $subname, $cond );
}
# b <line> [<condition>].
elsif ( $cmd =~ /^(\d*)\s*(.*)/ ) {
my $i = $1 || $dbline;
my $cond = length $2 ? $2 : '1';
- &cmd_b_line( $i, $cond );
+ cmd_b_line( $i, $cond );
}
} ## end sub cmd_pre580_b
my $line = shift || '*';
my $dbline = shift;
- return &cmd_prepost( $cmd, $line, $dbline );
+ return cmd_prepost( $cmd, $line, $dbline );
} ## end sub cmd_pre590_prepost
=head2 C<cmd_prepost>
https://perl5.git.perl.org / perl5.git / blobdiff