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_04';
+$VERSION = '1.39_05';
$header = "perl5db.pl version $VERSION";
$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 (
+ $evalarg,
+ $frame,
+ $ImmediateStop,
+ $line,
+ $onetimeDump,
+ %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) = @_;
# Cancel strict completely for the evaluated code, so the code
# the user evaluates won't be affected by it. (Shlomi Fish)
- return 'no strict; ($@, $!, $^E, $,, $/, $\, $^W) = @saved;'
+ return 'no strict; ($@, $!, $^E, $,, $/, $\, $^W) = @DB::saved;'
. "package $package;"; # this won't let them modify, alas
}
# Since we're only saving $@, we only have to localize the array element
# that it will be stored in.
local $saved[0]; # Preserve the old value of $@
- eval { &DB::save };
+ eval { DB::save() };
# Now see whether we need to report an error back to the user.
if ($at) {
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 {
+ *lock = sub(*) {};
+ *share = sub(*) {};
+ }
}
-# This would probably be better done with "use vars", but that wasn't around
-# when this code was originally written. (Neither was "use strict".) And on
-# the principle of not fiddling with something that was working, this was
-# left alone.
-warn( # Do not ;-)
- # These variables control the execution of 'dumpvar.pl'.
- $dumpvar::hashDepth,
- $dumpvar::arrayDepth,
- $dumpvar::dumpDBFiles,
- $dumpvar::dumpPackages,
- $dumpvar::quoteHighBit,
- $dumpvar::printUndef,
- $dumpvar::globPrint,
- $dumpvar::usageOnly,
-
- # used to control die() reporting in diesignal()
- $Carp::CarpLevel,
-
+# These variables control the execution of 'dumpvar.pl'.
+{
+ package dumpvar;
+ use vars qw(
+ $hashDepth
+ $arrayDepth
+ $dumpDBFiles
+ $dumpPackages
+ $quoteHighBit
+ $printUndef
+ $globPrint
+ $usageOnly
+ );
+}
- )
- if 0;
+# used to control die() reporting in diesignal()
+{
+ package Carp;
+ use vars qw($CarpLevel);
+}
# 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:
# Set up defaults for command recall and shell escape (note:
# these currently don't work in linemode debugging).
-&recallCommand("!") unless defined $prc;
-&shellBang("!") unless defined $psh;
+recallCommand("!") unless defined $prc;
+shellBang("!") unless defined $psh;
=pod
$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
# As noted, this test really doesn't check accurately that the debugger
# is running at a terminal or not.
-my $dev_tty = '/dev/tty';
- $dev_tty = 'TT:' if ($^O eq 'VMS');
use vars qw($rcfile);
-if ( -e $dev_tty ) { # this is the wrong metric!
- $rcfile = ".perldb";
-}
-else {
- $rcfile = "perldb.ini";
+{
+ my $dev_tty = (($^O eq 'VMS') ? 'TT:' : '/dev/tty');
+ # this is the wrong metric!
+ $rcfile = ((-e $dev_tty) ? ".perldb" : "perldb.ini");
}
=pod
use vars qw(@hist @truehist %postponed_file @typeahead);
-if ( exists $ENV{PERLDB_RESTART} ) {
-
- # We're restarting, so we don't need the flag that says to restart anymore.
- delete $ENV{PERLDB_RESTART};
-
- # $restart = 1;
+sub _restore_shared_globals_after_restart
+{
@hist = get_list('PERLDB_HIST');
%break_on_load = get_list("PERLDB_ON_LOAD");
%postponed = get_list("PERLDB_POSTPONE");
- share(@hist);
- share(@truehist);
- share(%break_on_load);
- share(%postponed);
+ share(@hist);
+ share(@truehist);
+ share(%break_on_load);
+ share(%postponed);
+}
+
+sub _restore_breakpoints_and_actions {
- # restore breakpoints/actions
my @had_breakpoints = get_list("PERLDB_VISITED");
+
for my $file_idx ( 0 .. $#had_breakpoints ) {
my $filename = $had_breakpoints[$file_idx];
my %pf = get_list("PERLDB_FILE_$file_idx");
}
}
- # restore options
- my %opt = get_list("PERLDB_OPT");
- my ( $opt, $val );
- while ( ( $opt, $val ) = each %opt ) {
+ return;
+}
+
+sub _restore_options_after_restart
+{
+ my %options_map = get_list("PERLDB_OPT");
+
+ while ( my ( $opt, $val ) = each %options_map ) {
$val =~ s/[\\\']/\\$1/g;
parse_options("$opt'$val'");
}
+ return;
+}
+
+sub _restore_globals_after_restart
+{
# restore original @INC
@INC = get_list("PERLDB_INC");
@ini_INC = @INC;
$pre = [ get_list("PERLDB_PRE") ];
$post = [ get_list("PERLDB_POST") ];
@typeahead = get_list( "PERLDB_TYPEAHEAD", @typeahead );
+
+ return;
+}
+
+
+if ( exists $ENV{PERLDB_RESTART} ) {
+
+ # We're restarting, so we don't need the flag that says to restart anymore.
+ delete $ENV{PERLDB_RESTART};
+
+ # $restart = 1;
+ _restore_shared_globals_after_restart();
+
+ _restore_breakpoints_and_actions();
+
+ # restore options
+ _restore_options_after_restart();
+
+ _restore_globals_after_restart();
} ## end if (exists $ENV{PERLDB_RESTART...
=head2 SETTING UP THE TERMINAL
=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
# Is Perl being run from a slave editor or graphical debugger?
# If so, don't use readline, and set $slave_editor = 1.
- $slave_editor =
- ( ( defined $main::ARGV[0] ) and ( $main::ARGV[0] eq '-emacs' ) );
- $rl = 0, shift(@main::ARGV) if $slave_editor;
+ if ($slave_editor = ( @main::ARGV && ( $main::ARGV[0] eq '-emacs' ) )) {
+ $rl = 0;
+ shift(@main::ARGV);
+ }
#require Term::ReadLine;
# Keep copies of the filehandles so that when the pager runs, it
# can close standard input without clobbering ours.
- $IN = \*IN, $OUT = \*OUT if $console or not defined $console;
+ if ($console or (not defined($console))) {
+ $IN = \*IN;
+ $OUT = \*OUT;
+ }
} ## end elsif (from if(defined $remoteport))
# Unbuffer DB::OUT. We need to see responses right away.
# 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
# If there was an afterinit() sub defined, call it. It will get
# executed in our scope, so it can fiddle with debugger globals.
if ( defined &afterinit ) { # May be defined in $rcfile
- &afterinit();
+ afterinit();
}
# Inform us about "Stack dump during die enabled ..." in dieLevel().
$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
);
-sub DB {
+our (
+ $doret,
+ $incr,
+ $stack_depth,
+ @stack,
+ @to_watch,
+ @old_watch,
+);
- # lock the debugger and get the thread id for the prompt
- lock($DBGR);
- my $tid;
- my $position;
- my ($prefix, $after, $infix);
- my $pat;
+sub _DB__determine_if_we_should_break
+{
+ # if we have something here, see if we should break.
+ # $stop is lexical and local to this block - $action on the other hand
+ # is global.
+ my $stop;
- if ($ENV{PERL5DB_THREADED}) {
- $tid = eval { "[".threads->tid."]" };
- }
+ if ( $dbline{$line}
+ && _is_breakpoint_enabled($filename, $line)
+ && (( $stop, $action ) = split( /\0/, $dbline{$line} ) ) )
+ {
- # Check for whether we should be running continuously or not.
- # _After_ the perl program is compiled, $single is set to 1:
- if ( $single and not $second_time++ ) {
+ # Stop if the stop criterion says to just stop.
+ if ( $stop eq '1' ) {
+ $signal |= 1;
+ }
- # Options say run non-stop. Run until we get an interrupt.
- if ($runnonstop) { # Disable until signal
- # If there's any call stack in place, turn off single
- # stepping into subs throughout the stack.
- for my $i (0 .. $stack_depth) {
- $stack[ $i ] &= ~1;
+ # It's a conditional stop; eval it in the user's context and
+ # see if we should stop. If so, remove the one-time sigil.
+ elsif ($stop) {
+ $evalarg = "\$DB::signal |= 1 if do {$stop}";
+ &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);
}
+ }
+ } ## end if ($dbline{$line} && ...
+}
- # And we are now no longer in single-step mode.
- $single = 0;
+sub _DB__is_finished {
+ if ($finished and $level <= 1) {
+ end_report();
+ return 1;
+ }
+ else {
+ return;
+ }
+}
- # If we simply returned at this point, we wouldn't get
- # the trace info. Fall on through.
- # return;
- } ## end if ($runnonstop)
+sub _DB__read_next_cmd
+{
+ my ($tid) = @_;
- elsif ($ImmediateStop) {
+ # We have a terminal, or can get one ...
+ if (!$term) {
+ setterm();
+ }
- # We are supposed to stop here; XXX probably a break.
- $ImmediateStop = 0; # We've processed it; turn it off
- $signal = 1; # Simulate an interrupt to force
- # us into the command loop
+ # ... and it belogs to this PID or we get one for this PID ...
+ if ($term_pid != $$) {
+ resetterm(1);
+ }
+
+ # ... and we got a line of command input ...
+ $cmd = DB::readline(
+ "$pidprompt $tid DB"
+ . ( '<' x $level )
+ . ( $#hist + 1 )
+ . ( '>' x $level ) . " "
+ );
+
+ return defined($cmd);
+}
+
+sub _DB__trim_command_and_return_first_component {
+ $cmd =~ s/\A\s+//s; # trim annoying leading whitespace
+ $cmd =~ s/\s+\z//s; # trim annoying trailing whitespace
+
+ $cmd =~ m{\A(\S*)};
+ return $1;
+}
+
+sub _DB__handle_f_command {
+ 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;
}
- } ## 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.
- $runnonstop = 0 if $single or $signal;
+ # 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 ($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($obj->position());
+ next CMD;
+ }
+
+ return;
+}
+
+sub _DB__handle_y_command {
+ my ($obj) = @_;
+
+ 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;
+ }
+}
+
+sub DB {
+
+ # lock the debugger and get the thread id for the prompt
+ lock($DBGR);
+ my $tid;
+ my $position;
+ my ($prefix, $after, $infix);
+ my $pat;
+ my $explicit_stop;
+
+ if ($ENV{PERL5DB_THREADED}) {
+ $tid = eval { "[".threads->tid."]" };
+ }
+
+ my $obj = DB::Obj->new(
+ {
+ position => \$position,
+ prefix => \$prefix,
+ after => \$after,
+ explicit_stop => \$explicit_stop,
+ infix => \$infix,
+ },
+ );
+
+ $obj->_DB_on_init__initialize_globals(@_);
# Preserve current values of $@, $!, $^E, $,, $/, $\, $^W.
# The code being debugged may have altered them.
# Last line in the program.
$max = $#dbline;
- # if we have something here, see if we should break.
- {
- # $stop is lexical and local to this block - $action on the other hand
- # is global.
- my $stop;
-
- if ( $dbline{$line}
- && _is_breakpoint_enabled($filename, $line)
- && (( $stop, $action ) = split( /\0/, $dbline{$line} ) ) )
- {
-
- # Stop if the stop criterion says to just stop.
- if ( $stop eq '1' ) {
- $signal |= 1;
- }
-
- # It's a conditional stop; eval it in the user's context and
- # see if we should stop. If so, remove the one-time sigil.
- elsif ($stop) {
- $evalarg = "\$DB::signal |= 1 if do {$stop}";
- &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);
- }
- }
- } ## end if ($dbline{$line} && ...
- }
+ _DB__determine_if_we_should_break(@_);
# Preserve the current stop-or-not, and see if any of the W
# (watch expressions) has changed.
my $was_signal = $signal;
# If we have any watch expressions ...
- if ( $trace & 2 ) {
- for my $n (0 .. $#to_watch) {
- $evalarg = $to_watch[$n];
- local $onetimeDump; # Tell DB::eval() to not output results
-
- # Fix context DB::eval() wants to return an array, but
- # we need a scalar here.
- my ($val) = join( "', '", &eval );
- $val = ( ( defined $val ) ? "'$val'" : 'undef' );
-
- # Did it change?
- if ( $val ne $old_watch[$n] ) {
-
- # Yep! Show the difference, and fake an interrupt.
- $signal = 1;
- print $OUT <<EOP;
-Watchpoint $n:\t$to_watch[$n] changed:
- old value:\t$old_watch[$n]
- new value:\t$val
-EOP
- $old_watch[$n] = $val;
- } ## end if ($val ne $old_watch...
- } ## end for my $n (0 ..
- } ## end if ($trace & 2)
+ $obj->_DB__handle_watch_expressions(@_);
=head2 C<watchfunction()>
# Make sure that we always print if asked for explicitly regardless
# of $trace_to_depth .
- my $explicit_stop = ($single || $was_signal);
+ $explicit_stop = ($single || $was_signal);
# Check to see if we should grab control ($single true,
# trace set appropriately, or we got a signal).
if ( $explicit_stop || ( $trace & 1 ) ) {
-
- # Yes, grab control.
- if ($slave_editor) {
-
- # Tell the editor to update its position.
- $position = "\032\032$filename:$line:0\n";
- print_lineinfo($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 ( $package eq 'DB::fake' ) {
-
- # Fallen off the end already.
- $term || &setterm;
- print_help(<<EOP);
-Debugged program terminated. Use B<q> to quit or B<R> to restart,
- use B<o> I<inhibit_exit> to avoid stopping after program termination,
- B<h q>, B<h R> or B<h o> to get additional info.
-EOP
-
- # Set the DB::eval context appropriately.
- $package = 'main';
- $usercontext = _calc_usercontext($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.
- $sub =~ s/\'/::/; # Swap Perl 4 package separators (') to
- # Perl 5 ones (sorry, we don't print Klingon
- #module names)
-
- $prefix = $sub =~ /::/ ? "" : ($package . '::');
- $prefix .= "$sub($filename:";
- $after = ( $dbline[$line] =~ /\n$/ ? '' : "\n" );
-
- # Break up the prompt if it's really long.
- if ( length($prefix) > 30 ) {
- $position = "$prefix$line):\n$line:\t$dbline[$line]$after";
- $prefix = "";
- $infix = ":\t";
- }
- else {
- $infix = "):\t";
- $position = "$prefix$line$infix$dbline[$line]$after";
- }
-
- # Print current line info, indenting if necessary.
- if ($frame) {
- print_lineinfo( ' ' x $stack_depth,
- "$line:\t$dbline[$line]$after" );
- }
- else {
- depth_print_lineinfo($explicit_stop, $position);
- }
-
- # Scan forward, stopping at either the end or the next
- # unbreakable line.
- for ( my $i = $line + 1 ; $i <= $max && $dbline[$i] == 0 ; ++$i )
- { #{ vi
-
- # Drop out on null statements, block closers, and comments.
- last if $dbline[$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.
- $after = ( $dbline[$i] =~ /\n$/ ? '' : "\n" );
-
- # Next executable line.
- my $incr_pos = "$prefix$i$infix$dbline[$i]$after";
- $position .= $incr_pos;
- if ($frame) {
-
- # Print it indented if tracing is on.
- print_lineinfo( ' ' x $stack_depth,
- "$i:\t$dbline[$i]$after" );
- }
- else {
- depth_print_lineinfo($explicit_stop, $incr_pos);
- }
- } ## end for ($i = $line + 1 ; $i...
- } ## end else [ if ($slave_editor)
+ $obj->_DB__grab_control(@_);
} ## end if ($single || ($trace...
=pod
=cut
# If there's an action, do it now.
- $evalarg = $action, &eval if $action;
+ if ($action) {
+ $evalarg = $action;
+ DB::eval();
+ }
# Are we nested another level (e.g., did we evaluate a function
# that had a breakpoint in it at the debugger prompt)?
# Do any pre-prompt actions.
foreach $evalarg (@$pre) {
- &eval;
+ DB::eval();
}
# Complain about too much recursion if we passed the limit.
- print $OUT $stack_depth . " levels deep in subroutine calls!\n"
- if $single & 4;
+ if ($single & 4) {
+ print $OUT $stack_depth . " levels deep in subroutine calls!\n";
+ }
# The line we're currently on. Set $incr to -1 to stay here
# until we get a command that tells us to advance.
my $selected;
CMD:
- while (
-
- # We have a terminal, or can get one ...
- ( $term || &setterm ),
-
- # ... and it belogs to this PID or we get one for this PID ...
- ( $term_pid == $$ or resetterm(1) ),
-
- # ... and we got a line of command input ...
- defined(
- $cmd = &readline(
- "$pidprompt $tid DB"
- . ( '<' x $level )
- . ( $#hist + 1 )
- . ( '>' x $level ) . " "
- )
- )
- )
+ 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 );
+ my $i = _DB__trim_command_and_return_first_component();
=head3 COMMAND ALIASES
=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;
- }
+ $obj->_handle_t_command;
=head4 C<S> - list subroutines matching/not matching a pattern
=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;
- }
+ $obj->_handle_S_command;
=head4 C<X> - list variables in current package
Since the C<V> command actually processes this, just change this to the
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";
- }
+ $obj->_handle_V_command_and_X_command;
- # 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
+=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 (($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;
- }
- }
+ _DB__handle_f_command();
=head4 C<.> - return to last-executed line.
=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;
- }
+ _DB__handle_dot_command($obj);
=head4 C<-> - back one window
=cut
# - - back a window.
- if ($cmd eq '-') {
+ $obj->_handle_dash_command;
- # back up by a window; go to 1 if back too far.
- $start -= $incr + $window + 1;
- $start = 1 if $start <= 0;
- $incr = $window - 1;
-
- # 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>, {, {{>
+=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
problems, most notably that the default case of several commands destroying
=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;
- }
+ _DB__handle_y_command($obj);
=head3 COMMANDS NOT WORKING AFTER PROGRAM ENDS
# n - next
if ($cmd eq 'n') {
- end_report(), next CMD if $finished and $level <= 1;
+ next CMD if _DB__is_finished();
# Single step, but don't enter subs.
$single = 2;
# Get out and restart the command loop if program
# has finished.
- end_report(), next CMD if $finished and $level <= 1;
+ next CMD if _DB__is_finished();
# Single step should enter subs.
$single = 1;
# Hey, show's over. The debugged program finished
# executing already.
- end_report(), next CMD if $finished and $level <= 1;
+ next CMD if _DB__is_finished();
# Capture the place to put a one-time break.
$subname = $i;
if ($cmd eq 'r') {
# Can't do anything if the program's over.
- end_report(), next CMD if $finished and $level <= 1;
+ next CMD if _DB__is_finished();
# Turn on stack trace.
$stack[$stack_depth] |= 1;
local $SIG{__WARN__};
# Create the pattern.
- eval '$inpat =~ m' . "\a$inpat\a";
+ eval 'no strict q/vars/; $inpat =~ m' . "\a$inpat\a";
if ( $@ ne "" ) {
# Oops. Bad pattern. No biscuit.
# Done in eval so nothing breaks if the pattern
# does something weird.
eval '
+ no strict q/vars/;
for (;;) {
# Move ahead one line.
++$start;
# Search inside the eval to prevent pattern badness
# from killing us.
eval '
+ no strict q/vars/;
for (;;) {
# Back up a line.
--$start;
redo PIPE;
}
-=head3 END OF COMMAND PARSING
+=head3 END OF COMMAND PARSING
+
+Anything left in C<$cmd> at this point is a Perl expression that we want to
+evaluate. We'll always evaluate in the user's context, and fully qualify
+any variables we might want to address in the C<DB> package.
+
+=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:
+
+ # Make sure the flag that says "the debugger's running" is
+ # still on, to make sure we get control again.
+ $evalarg = "\$^D = \$^D | \$DB::db_stop;\n$cmd";
+
+ # Run *our* eval that executes in the caller's context.
+ DB::eval();
+
+ # Turn off the one-time-dump stuff now.
+ if ($onetimeDump) {
+ $onetimeDump = undef;
+ $onetimedumpDepth = undef;
+ }
+ elsif ( $term_pid == $$ ) {
+ eval { # May run under miniperl, when not available...
+ STDOUT->flush();
+ STDERR->flush();
+ };
+
+ # XXX If this is the master pid, print a newline.
+ print {$OUT} "\n";
+ }
+ } ## end while (($term || &setterm...
+
+=head3 POST-COMMAND PROCESSING
+
+After each command, we check to see if the command output was piped anywhere.
+If so, we go through the necessary code to unhook the pipe and go back to
+our standard filehandles for input and output.
+
+=cut
+
+ continue { # CMD:
+
+ # At the end of every command:
+ if ($piped) {
+
+ # Unhook the pipe mechanism now.
+ if ( $pager =~ /^\|/ ) {
+
+ # No error from the child.
+ $? = 0;
+
+ # we cannot warn here: the handle is missing --tchrist
+ close(OUT) || print SAVEOUT "\nCan't close DB::OUT\n";
+
+ # most of the $? crud was coping with broken cshisms
+ # $? is explicitly set to 0, so this never runs.
+ if ($?) {
+ print SAVEOUT "Pager '$pager' failed: ";
+ if ( $? == -1 ) {
+ print SAVEOUT "shell returned -1\n";
+ }
+ elsif ( $? >> 8 ) {
+ print SAVEOUT ( $? & 127 )
+ ? " (SIG#" . ( $? & 127 ) . ")"
+ : "", ( $? & 128 ) ? " -- core dumped" : "", "\n";
+ }
+ else {
+ print SAVEOUT "status ", ( $? >> 8 ), "\n";
+ }
+ } ## end if ($?)
+
+ # Reopen filehandle for our output (if we can) and
+ # restore STDOUT (if we can).
+ open( OUT, ">&STDOUT" ) || &warn("Can't restore DB::OUT");
+ open( STDOUT, ">&SAVEOUT" )
+ || &warn("Can't restore STDOUT");
+
+ # Turn off pipe exception handler if necessary.
+ $SIG{PIPE} = "DEFAULT" if $SIG{PIPE} eq \&DB::catch;
+
+ # Will stop ignoring SIGPIPE if done like nohup(1)
+ # does SIGINT but Perl doesn't give us a choice.
+ } ## end if ($pager =~ /^\|/)
+ else {
+
+ # Non-piped "pager". Just restore STDOUT.
+ open( OUT, ">&SAVEOUT" ) || &warn("Can't restore DB::OUT");
+ }
+
+ # Close filehandle pager was using, restore the normal one
+ # if necessary,
+ close(SAVEOUT);
+ select($selected), $selected = "" unless $selected eq "";
+
+ # No pipes now.
+ $piped = "";
+ } ## end if ($piped)
+ } # CMD:
+
+=head3 COMMAND LOOP TERMINATION
+
+When commands have finished executing, we come here. If the user closed the
+input filehandle, we turn on C<$fall_off_end> to emulate a C<q> command. We
+evaluate any post-prompt items. We restore C<$@>, C<$!>, C<$^E>, C<$,>, C<$/>,
+C<$\>, and C<$^W>, and return a null list as expected by the Perl interpreter.
+The interpreter will then execute the next line and then return control to us
+again.
+
+=cut
+
+ # No more commands? Quit.
+ $fall_off_end = 1 unless defined $cmd; # Emulate 'q' on EOF
+
+ # Evaluate post-prompt commands.
+ foreach $evalarg (@$post) {
+ DB::eval();
+ }
+ } # if ($single || $signal)
+
+ # Put the user's globals back where you found them.
+ ( $@, $!, $^E, $,, $/, $\, $^W ) = @saved;
+ ();
+} ## end sub DB
+
+package DB::Obj;
+
+sub new {
+ my $class = shift;
+
+ my $self = bless {}, $class;
+
+ $self->_init(@_);
+
+ return $self;
+}
+
+sub _init {
+ my ($self, $args) = @_;
+
+ %{$self} = (%$self, %$args);
+
+ return;
+}
+
+{
+ no strict 'refs';
+ foreach my $slot_name (qw(after explicit_stop infix position prefix)) {
+ my $slot = $slot_name;
+ *{$slot} = sub {
+ my $self = shift;
+
+ if (@_) {
+ ${ $self->{$slot} } = shift;
+ }
+
+ return ${ $self->{$slot} };
+ };
+
+ *{"append_to_$slot"} = sub {
+ my $self = shift;
+ my $s = shift;
+
+ return $self->$slot($self->$slot . $s);
+ };
+ }
+}
+
+sub _DB_on_init__initialize_globals
+{
+ 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 ( $single and not $second_time++ ) {
+
+ # Options say run non-stop. Run until we get an interrupt.
+ if ($runnonstop) { # Disable until signal
+ # If there's any call stack in place, turn off single
+ # stepping into subs throughout the stack.
+ for my $i (0 .. $stack_depth) {
+ $stack[ $i ] &= ~1;
+ }
+
+ # And we are now no longer in single-step mode.
+ $single = 0;
+
+ # If we simply returned at this point, we wouldn't get
+ # the trace info. Fall on through.
+ # return;
+ } ## end if ($runnonstop)
+
+ elsif ($ImmediateStop) {
+
+ # We are supposed to stop here; XXX probably a break.
+ $ImmediateStop = 0; # We've processed it; turn it off
+ $signal = 1; # Simulate an interrupt to force
+ # us into the command loop
+ }
+ } ## end if ($single and not $second_time...
+
+ # If we're in single-step mode, or an interrupt (real or fake)
+ # has occurred, turn off non-stop mode.
+ $runnonstop = 0 if $single or $signal;
+
+ return;
+}
+
+sub _DB__handle_watch_expressions
+{
+ my $self = shift;
+
+ if ( $trace & 2 ) {
+ for my $n (0 .. $#to_watch) {
+ $evalarg = $to_watch[$n];
+ local $onetimeDump; # Tell DB::eval() to not output results
+
+ # Fix context DB::eval() wants to return an array, but
+ # we need a scalar here.
+ my ($val) = join( "', '", DB::eval() );
+ $val = ( ( defined $val ) ? "'$val'" : 'undef' );
+
+ # Did it change?
+ if ( $val ne $old_watch[$n] ) {
+
+ # Yep! Show the difference, and fake an interrupt.
+ $signal = 1;
+ print {$OUT} <<EOP;
+Watchpoint $n:\t$to_watch[$n] changed:
+ old value:\t$old_watch[$n]
+ new value:\t$val
+EOP
+ $old_watch[$n] = $val;
+ } ## end if ($val ne $old_watch...
+ } ## end for my $n (0 ..
+ } ## end if ($trace & 2)
+
+ return;
+}
+
+sub _my_print_lineinfo
+{
+ my ($self, $i, $incr_pos) = @_;
+
+ 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 _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
-Anything left in C<$cmd> at this point is a Perl expression that we want to
-evaluate. We'll always evaluate in the user's context, and fully qualify
-any variables we might want to address in the C<DB> package.
+ else {
-=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;
- }
+ # 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)
- # s - single-step. Remember the last command was 's'.
- if ($cmd =~ s/\As\s/\$DB::single = 1;\n/) {
- $laststep = 's';
- }
+ $self->prefix($DB::sub =~ /::/ ? "" : ($DB::package . '::'));
+ $self->append_to_prefix( "$DB::sub(${DB::filename}:" );
+ $self->after( $self->_curr_line =~ /\n$/ ? '' : "\n" );
- # n - single-step, but not into subs. Remember last command
- # was 'n'.
- if ($cmd =~ s#\An\s#\$DB::single = 2;\n#) {
- $laststep = '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
+ );
+ }
- } # PIPE:
+ # Print current line info, indenting if necessary.
+ $self->_my_print_lineinfo($line, $self->position);
- # 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";
+ my $i;
+ my $line_i = sub { return $DB::dbline[$i]; };
- # Run *our* eval that executes in the caller's context.
- &eval;
+ # Scan forward, stopping at either the end or the next
+ # unbreakable line.
+ for ( $i = $line + 1 ; $i <= $DB::max && $line_i->() == 0 ; ++$i )
+ { #{ vi
- # Turn off the one-time-dump stuff now.
- if ($onetimeDump) {
- $onetimeDump = undef;
- $onetimedumpDepth = undef;
- }
- elsif ( $term_pid == $$ ) {
- eval { # May run under miniperl, when not available...
- STDOUT->flush();
- STDERR->flush();
- };
+ # Drop out on null statements, block closers, and comments.
+ last if $line_i->() =~ /^\s*[\;\}\#\n]/;
- # XXX If this is the master pid, print a newline.
- print $OUT "\n";
- }
- } ## end while (($term || &setterm...
+ # Drop out if the user interrupted us.
+ last if $signal;
-=head3 POST-COMMAND PROCESSING
+ # Append a newline if the line doesn't have one. Can happen
+ # in eval'ed text, for instance.
+ $self->after( $line_i->() =~ /\n$/ ? '' : "\n" );
-After each command, we check to see if the command output was piped anywhere.
-If so, we go through the necessary code to unhook the pipe and go back to
-our standard filehandles for input and output.
+ # 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)
-=cut
+ return;
+}
- continue { # CMD:
+sub _handle_t_command {
+ if (my ($levels) = $DB::cmd =~ /\At(?:\s+(\d+))?\z/) {
+ $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;
+ }
- # At the end of every command:
- if ($piped) {
+ return;
+}
- # Unhook the pipe mechanism now.
- if ( $pager =~ /^\|/ ) {
- # No error from the child.
- $? = 0;
+sub _handle_S_command {
+ if (my ($print_all_subs, $should_reverse, $Spatt)
+ = $DB::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;
- # we cannot warn here: the handle is missing --tchrist
- close(OUT) || print SAVEOUT "\nCan't close DB::OUT\n";
+ # Need to make these sane here.
+ local $\ = '';
+ local $, = '';
- # 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 ($?)
+ # 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;
+ }
- # 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");
+ return;
+}
- # Turn off pipe exception handler if necessary.
- $SIG{PIPE} = "DEFAULT" if $SIG{PIPE} eq \&DB::catch;
+sub _handle_V_command_and_X_command {
- # Will stop ignoring SIGPIPE if done like nohup(1)
- # does SIGINT but Perl doesn't give us a choice.
- } ## end if ($pager =~ /^\|/)
- else {
+ $DB::cmd =~ s/^X\b/V $DB::package/;
- # Non-piped "pager". Just restore STDOUT.
- open( OUT, ">&SAVEOUT" ) || &warn("Can't restore DB::OUT");
- }
+ # Bare V commands get the currently-being-debugged package
+ # added.
+ if ($DB::cmd eq "V") {
+ $DB::cmd = "V $DB::package";
+ }
- # Close filehandle pager was using, restore the normal one
- # if necessary,
- close(SAVEOUT);
- select($selected), $selected = "" unless $selected eq "";
+ # V - show variables in package.
+ if (my ($new_packname, $new_vars_str) =
+ $DB::cmd =~ /\AV\b\s*(\S+)\s*(.*)/) {
- # No pipes now.
- $piped = "";
- } ## end if ($piped)
- } # CMD:
+ # Save the currently selected filehandle and
+ # force output to debugger's filehandle (dumpvar
+ # just does "print" for output).
+ my $savout = select($OUT);
-=head3 COMMAND LOOP TERMINATION
+ # Grab package name and variables to dump.
+ $packname = $new_packname;
+ my @vars = split( ' ', $new_vars_str );
-When commands have finished executing, we come here. If the user closed the
-input filehandle, we turn on C<$fall_off_end> to emulate a C<q> command. We
-evaluate any post-prompt items. We restore C<$@>, C<$!>, C<$^E>, C<$,>, C<$/>,
-C<$\>, and C<$^W>, and return a null list as expected by the Perl interpreter.
-The interpreter will then execute the next line and then return control to us
-again.
+ # If main::dumpvar isn't here, get it.
+ do 'dumpvar.pl' || die $@ unless defined &main::dumpvar;
+ if ( defined &main::dumpvar ) {
-=cut
+ # We got it. Turn off subroutine entry/exit messages
+ # for the moment, along with return values.
+ local $frame = 0;
+ local $doret = -2;
- # No more commands? Quit.
- $fall_off_end = 1 unless defined $cmd; # Emulate 'q' on EOF
+ # 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
+ );
+ };
- # Evaluate post-prompt commands.
- foreach $evalarg (@$post) {
- &eval;
+ # 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";
}
- } # if ($single || $signal)
- # Put the user's globals back where you found them.
- ( $@, $!, $^E, $,, $/, $\, $^W ) = @saved;
- ();
-} ## end sub DB
+ # Restore the output filehandle, and go round again.
+ select($savout);
+ next CMD;
+ }
+
+ return;
+}
+
+sub _handle_dash_command {
+
+ if ($DB::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).
+ $DB::cmd = 'l ' . ($start) . '+';
+ }
+ return;
+}
+
+package DB;
# The following code may be executed now:
# BEGIN {warn 4}
# We need to fully qualify the name ("DB::sub") to make "use strict;"
# happy. -- Shlomi Fish
sub DB::sub {
- # Do not use a regex in this subroutine -> results in corrupted memory
- # See: [perl #66110]
+ # 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.
# 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-- ];
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.
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 ) {
# if delete_action blows up for some reason, in which case
# we print $@ and get out.
if ( $line eq '*' ) {
- eval { &delete_action(); 1 } or print $OUT $@ and return;
+ if (! eval { _delete_all_actions(); 1 }) {
+ print {$OUT} $@;
+ return;
+ }
}
# There's a real line number. Pass it to delete_action.
# Error trapping is as above.
elsif ( $line =~ /^(\S.*)/ ) {
- eval { &delete_action($1); 1 } or print $OUT $@ and return;
+ if (! eval { delete_action($1); 1 }) {
+ print {$OUT} $@;
+ return;
+ }
}
# Swing and a miss. Bad syntax.
=cut
+sub _remove_action_from_dbline {
+ my $i = shift;
+
+ $dbline{$i} =~ s/\0[^\0]*//; # \^a
+ delete $dbline{$i} if $dbline{$i} eq '';
+
+ return;
+}
+
+sub _delete_all_actions {
+ print {$OUT} "Deleting all actions...\n";
+
+ for my $file ( keys %had_breakpoints ) {
+ local *dbline = $main::{ '_<' . $file };
+ $max = $#dbline;
+ my $was;
+ for my $i (1 .. $max) {
+ if ( defined $dbline{$i} ) {
+ _remove_action_from_dbline($i);
+ }
+ }
+
+ unless ( $had_breakpoints{$file} &= ~2 ) {
+ delete $had_breakpoints{$file};
+ }
+ }
+
+ return;
+}
+
sub delete_action {
my $i = shift;
- if ( defined($i) ) {
+ if ( defined($i) ) {
# Can there be one?
die "Line $i has no action .\n" if $dbline[$i] == 0;
# Nuke whatever's there.
- $dbline{$i} =~ s/\0[^\0]*//; # \^a
- delete $dbline{$i} if $dbline{$i} eq '';
+ _remove_action_from_dbline($i);
}
else {
- print $OUT "Deleting all actions...\n";
- for my $file ( keys %had_breakpoints ) {
- local *dbline = $main::{ '_<' . $file };
- $max = $#dbline;
- my $was;
- for $i (1 .. $max) {
- if ( defined $dbline{$i} ) {
- $dbline{$i} =~ s/\0[^\0]*//;
- delete $dbline{$i} if $dbline{$i} eq '';
- }
- unless ( $had_breakpoints{$file} &= ~2 ) {
- delete $had_breakpoints{$file};
- }
- } ## end for ($i = 1 .. $max)
- } ## end for my $file (keys %had_breakpoints)
- } ## end else [ if (defined($i))
-} ## end sub delete_action
+ _delete_all_actions();
+ }
+}
=head3 C<cmd_b> (command)
my $line = shift; # [.|line] [cond]
my $dbline = shift;
+ my $default_cond = sub {
+ my $cond = shift;
+ return length($cond) ? $cond : '1';
+ };
+
# Make . the current line number if it's there..
$line =~ s/^\.(\s|\z)/$dbline$1/;
# No line number, no condition. Simple break on current line.
if ( $line =~ /^\s*$/ ) {
- &cmd_b_line( $dbline, 1 );
+ cmd_b_line( $dbline, 1 );
}
# Break on load for a file.
- elsif ( $line =~ /^load\b\s*(.*)/ ) {
- my $file = $1;
- $file =~ s/\s+$//;
- &cmd_b_load($file);
+ elsif ( my ($file) = $line =~ /^load\b\s*(.*)/ ) {
+ $file =~ s/\s+\z//;
+ cmd_b_load($file);
}
# b compile|postpone <some sub> [<condition>]
# The interpreter actually traps this one for us; we just put the
# necessary condition in the %postponed hash.
- elsif ( $line =~ /^(postpone|compile)\b\s*([':A-Za-z_][':\w]*)\s*(.*)/ ) {
-
- # Capture the condition if there is one. Make it true if none.
- my $cond = length $3 ? $3 : '1';
-
- # Save the sub name and set $break to 1 if $1 was 'postpone', 0
- # if it was 'compile'.
- my ( $subname, $break ) = ( $2, $1 eq 'postpone' );
+ elsif ( my ($action, $subname, $cond)
+ = $line =~ /^(postpone|compile)\b\s*([':A-Za-z_][':\w]*)\s*(.*)/ ) {
# De-Perl4-ify the name - ' separators to ::.
- $subname =~ s/\'/::/g;
+ $subname =~ s/'/::/g;
# Qualify it into the current package unless it's already qualified.
$subname = "${package}::" . $subname unless $subname =~ /::/;
$subname = "main" . $subname if substr( $subname, 0, 2 ) eq "::";
# Save the break type for this sub.
- $postponed{$subname} = $break ? "break +0 if $cond" : "compile";
+ $postponed{$subname} = (($action eq 'postpone')
+ ? ( "break +0 if " . $default_cond->($cond) )
+ : "compile");
} ## end elsif ($line =~ ...
# b <filename>:<line> [<condition>]
- elsif ($line =~ /\A(\S+[^:]):(\d+)\s*(.*)/ms) {
- my ($filename, $line_num, $cond) = ($1, $2, $3);
+ elsif (my ($filename, $line_num, $cond)
+ = $line =~ /\A(\S+[^:]):(\d+)\s*(.*)/ms) {
cmd_b_filename_line(
$filename,
$line_num,
);
}
# b <sub name> [<condition>]
- elsif ( $line =~ /^([':A-Za-z_][':\w]*(?:\[.*\])?)\s*(.*)/ ) {
+ elsif ( my ($new_subname, $new_cond) =
+ $line =~ /^([':A-Za-z_][':\w]*(?:\[.*\])?)\s*(.*)/ ) {
#
- $subname = $1;
- my $cond = length $2 ? $2 : '1';
- &cmd_b_sub( $subname, $cond );
+ $subname = $new_subname;
+ cmd_b_sub( $subname, $default_cond->($new_cond) );
}
# b <line> [<condition>].
- elsif ( $line =~ /^(\d*)\s*(.*)/ ) {
+ elsif ( my ($line_n, $cond) = $line =~ /^(\d*)\s*(.*)/ ) {
# Capture the line. If none, it's the current line.
- $line = $1 || $dbline;
-
- # If there's no condition, make it '1'.
- my $cond = length $2 ? $2 : '1';
+ $line = $line_n || $dbline;
# Break on line.
- &cmd_b_line( $line, $cond );
+ cmd_b_line( $line, $default_cond->($cond) );
}
# Line didn't make sense.
else {
print "confused by line($line)?\n";
}
+
+ return;
} ## end sub cmd_b
=head3 C<break_on_load> (API)
=cut
sub break_on_line {
- my ( $i, $cond ) = @_;
-
- # Always true if no condition supplied.
- $cond = 1 unless @_ >= 2;
+ my $i = shift;
+ my $cond = @_ ? shift(@_) : 1;
my $inii = $i;
my $after = '';
_set_breakpoint_enabled_status($filename, $i, 1);
}
+
+ return;
} ## end sub break_on_line
=head3 cmd_b_line(line, [condition]) (command)
=cut
sub break_on_filename_line {
- my ( $f, $i, $cond ) = @_;
-
- # Always true if condition left off.
- $cond = 1 unless @_ >= 3;
+ my $f = shift;
+ my $i = shift;
+ my $cond = @_ ? shift(@_) : 1;
# Switch the magical hash temporarily.
local *dbline = $main::{ '_<' . $f };
# Add the breakpoint.
break_on_line( $i, $cond );
+
+ return;
} ## end sub break_on_filename_line
=head3 break_on_filename_line_range(file, from, to, [condition]) (API)
=cut
sub break_on_filename_line_range {
- my ( $f, $from, $to, $cond ) = @_;
+ my $f = shift;
+ my $from = shift;
+ my $to = shift;
+ my $cond = @_ ? shift(@_) : 1;
# Find a breakable line if there is one.
my $i = breakable_line_in_filename( $f, $from, $to );
- # Always true if missing.
- $cond = 1 unless @_ >= 3;
-
# Add the breakpoint.
break_on_filename_line( $f, $i, $cond );
+
+ return;
} ## end sub break_on_filename_line_range
=head3 subroutine_filename_lines(subname, [condition]) (API)
=cut
sub subroutine_filename_lines {
- my ( $subname, $cond ) = @_;
+ my ( $subname ) = @_;
# Returned value from find_sub() is fullpathname:startline-endline.
- # The match creates the list (fullpathname, start, end). Falling off
- # the end of the subroutine returns this implicitly.
- find_sub($subname) =~ /^(.*):(\d+)-(\d+)$/;
+ # The match creates the list (fullpathname, start, end).
+ return (find_sub($subname) =~ /^(.*):(\d+)-(\d+)$/);
} ## end sub subroutine_filename_lines
=head3 break_subroutine(subname) (API)
# Put a break the first place possible in the range of lines
# that make up this subroutine.
break_on_filename_line_range( $file, $s, $e, $cond );
+
+ return;
} ## end sub break_subroutine
=head3 cmd_b_sub(subname, [condition]) (command)
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)
my $line = shift;
foreach my $isa ( split( /\s+/, $line ) ) {
$evalarg = $isa;
- ($isa) = &eval;
+ ($isa) = DB::eval();
no strict 'refs';
print join(
', ',
# Set up for DB::eval() - evaluate in *user* context.
$evalarg = $1;
# $evalarg = $2;
- my ($s) = &eval;
+ my ($s) = DB::eval();
# Ooops. Bad scalar.
if ($@) {
=cut
+sub _add_watch_expr {
+ my $expr = shift;
+
+ # ... save it.
+ push @to_watch, $expr;
+
+ # Parameterize DB::eval and call it to get the expression's value
+ # in the user's context. This version can handle expressions which
+ # return a list value.
+ $evalarg = $expr;
+ my ($val) = join( ' ', DB::eval() );
+ $val = ( defined $val ) ? "'$val'" : 'undef';
+
+ # Save the current value of the expression.
+ push @old_watch, $val;
+
+ # We are now watching expressions.
+ $trace |= 2;
+
+ return;
+}
+
sub cmd_w {
my $cmd = shift;
my $expr = shift || '';
# If expression is not null ...
- if ( $expr =~ /^(\S.*)/ ) {
-
- # ... save it.
- push @to_watch, $expr;
-
- # Parameterize DB::eval and call it to get the expression's value
- # in the user's context. This version can handle expressions which
- # return a list value.
- $evalarg = $expr;
- my ($val) = join( ' ', &eval );
- $val = ( defined $val ) ? "'$val'" : 'undef';
-
- # Save the current value of the expression.
- push @old_watch, $val;
-
- # We are now watching expressions.
- $trace |= 2;
+ if ( $expr =~ /\A\S/ ) {
+ _add_watch_expr($expr);
} ## end if ($expr =~ /^(\S.*)/)
# You have to give one to get one.
else {
print $OUT "Adding a watch-expression requires an expression\n"; # hint
}
-} ## end sub cmd_w
+
+ return;
+}
=head3 C<cmd_W> - delete watch expressions (command)
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);
=cut
sub print_help {
- my $help_str = (@_);
+ my $help_str = shift;
# Restore proper alignment destroyed by eeevil I<> and B<>
# ornaments: A pox on both their houses!
# 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.
# Get the current value of the expression.
# Doesn't handle expressions returning list values!
$evalarg = $1;
- my ($val) = &eval;
+ my ($val) = DB::eval();
$val = ( defined $val ) ? "'$val'" : 'undef';
# Save it.
https://perl5.git.perl.org / perl5.git / blobdiff