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";
# 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
# 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
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().
$end
);
-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;
+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
- }
- } ## end if ($single and not $second_time...
+ # ... and it belogs to this PID or we get one for this PID ...
+ if ($term_pid != $$) {
+ resetterm(1);
+ }
- # 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;
+ # ... 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 {
+
+ # 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
$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
# 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;
$evalarg = "\$^D = \$^D | \$DB::db_stop;\n$cmd";
# Run *our* eval that executes in the caller's context.
- &eval;
+ DB::eval();
# Turn off the one-time-dump stuff now.
if ($onetimeDump) {
$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...
# Evaluate post-prompt commands.
foreach $evalarg (@$post) {
- &eval;
+ DB::eval();
}
} # if ($single || $signal)
();
} ## 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 ( $DB::single and not $DB::second_time++ ) {
+
+ # Options say run non-stop. Run until we get an interrupt.
+ if ($DB::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;
+ }
+
+ # And we are now no longer in single-step mode.
+ $DB::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) {
+
+ # 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
+ # 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;
+
+ return;
+}
+
+sub _DB__handle_watch_expressions
+{
+ my $self = shift;
+
+ if ( $DB::trace & 2 ) {
+ for my $n (0 .. $#DB::to_watch) {
+ $DB::evalarg = $DB::to_watch[$n];
+ local $DB::onetimeDump; # Tell DB::eval() to not output results
+
+ # Fix context DB::eval() wants to return an array, but
+ # we need a scalar here.
+ my ($val) = join( "', '", DB::eval() );
+ $val = ( ( defined $val ) ? "'$val'" : 'undef' );
+
+ # Did it change?
+ if ( $val ne $DB::old_watch[$n] ) {
+
+ # Yep! Show the difference, and fake an interrupt.
+ $DB::signal = 1;
+ print {$DB::OUT} <<EOP;
+Watchpoint $n:\t$DB::to_watch[$n] changed:
+ old value:\t$DB::old_watch[$n]
+ new value:\t$val
+EOP
+ $DB::old_watch[$n] = $val;
+ } ## end if ($val ne $old_watch...
+ } ## end for my $n (0 ..
+ } ## end if ($trace & 2)
+
+ return;
+}
+
+sub _my_print_lineinfo
+{
+ my ($self, $i, $incr_pos) = @_;
+
+ 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);
+ }
+}
+
+sub _curr_line {
+ return $DB::dbline[$DB::line];
+}
+
+sub _DB__grab_control
+{
+ my $self = shift;
+
+ # Yes, grab control.
+ if ($DB::slave_editor) {
+
+ # Tell the editor to update its position.
+ $self->position("\032\032${DB::filename}:${DB::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 . "$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
+ );
+ }
+
+ # Print current line info, indenting if necessary.
+ $self->_my_print_lineinfo($DB::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 = $DB::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 $DB::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;
+}
+
+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.
# 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)
# No line spec? Use dbline.
# If there is one, use it if it's non-zero, or wipe it out if it is.
- my $line = ( $_[0] =~ /^\./ ) ? $dbline : shift || '';
+ my $line = ( $_[0] =~ /\A\./ ) ? $dbline : (shift || '');
my $dbline = shift;
# If the line was dot, make the line the current one.
# If it's * we're deleting all the breakpoints.
if ( $line eq '*' ) {
- eval { &delete_breakpoint(); 1 } or print $OUT $@ and return;
+ if (not eval { delete_breakpoint(); 1 }) {
+ print {$OUT} $@;
+ }
}
# If there is a line spec, delete the breakpoint on that line.
- elsif ( $line =~ /^(\S.*)/ ) {
- if (not eval { &delete_breakpoint( $line || $dbline ); 1 }) {
+ elsif ( $line =~ /\A(\S.*)/ ) {
+ if (not eval { delete_breakpoint( $line || $dbline ); 1 }) {
local $\ = '';
- print $OUT $@ and return;
+ print {$OUT} $@;
}
} ## end elsif ($line =~ /^(\S.*)/)
# No line spec.
else {
- print $OUT
+ print {$OUT}
"Deleting a breakpoint requires a line number, or '*' for all\n"
; # hint
}
+
+ return;
} ## end sub cmd_B
=head3 delete_breakpoint([line]) (API)
=cut
-sub delete_breakpoint {
- my $i = shift;
+sub _remove_breakpoint_entry {
+ my ($fn, $i) = @_;
- my $fn = $filename;
+ delete $dbline{$i};
+ _delete_breakpoint_data_ref($fn, $i);
- # If we got a line, delete just that one.
- if ( defined($i) ) {
+ return;
+}
- # Woops. This line wasn't breakable at all.
- die "Line $i not breakable.\n" if $dbline[$i] == 0;
+sub _delete_all_breakpoints {
+ print {$OUT} "Deleting all breakpoints...\n";
- # Kill the condition, but leave any action.
- $dbline{$i} =~ s/^[^\0]*//;
+ # %had_breakpoints lists every file that had at least one
+ # breakpoint in it.
+ for my $fn ( keys %had_breakpoints ) {
- # Remove the entry entirely if there's no action left.
- if ($dbline{$i} eq '') {
- delete $dbline{$i};
- _delete_breakpoint_data_ref($fn, $i);
+ # Switch to the desired file temporarily.
+ local *dbline = $main::{ '_<' . $fn };
+
+ $max = $#dbline;
+
+ # For all lines in this file ...
+ for my $i (1 .. $max) {
+
+ # If there's a breakpoint or action on this line ...
+ if ( defined $dbline{$i} ) {
+
+ # ... remove the breakpoint.
+ $dbline{$i} =~ s/\A[^\0]+//;
+ if ( $dbline{$i} =~ s/\A\0?\z// ) {
+ # Remove the entry altogether if no action is there.
+ _remove_breakpoint_entry($fn, $i);
+ }
+ } ## end if (defined $dbline{$i...
+ } ## end for $i (1 .. $max)
+
+ # If, after we turn off the "there were breakpoints in this file"
+ # bit, the entry in %had_breakpoints for this file is zero,
+ # we should remove this file from the hash.
+ if ( not $had_breakpoints{$fn} &= (~1) ) {
+ delete $had_breakpoints{$fn};
}
- }
+ } ## end for my $fn (keys %had_breakpoints)
- # No line; delete them all.
- else {
- print $OUT "Deleting all breakpoints...\n";
+ # Kill off all the other breakpoints that are waiting for files that
+ # haven't been loaded yet.
+ undef %postponed;
+ undef %postponed_file;
+ undef %break_on_load;
- # %had_breakpoints lists every file that had at least one
- # breakpoint in it.
- for my $file ( keys %had_breakpoints ) {
+ return;
+}
- # Switch to the desired file temporarily.
- local *dbline = $main::{ '_<' . $file };
+sub _delete_breakpoint_from_line {
+ my ($i) = @_;
- $max = $#dbline;
- my $was;
+ # Woops. This line wasn't breakable at all.
+ die "Line $i not breakable.\n" if $dbline[$i] == 0;
- # For all lines in this file ...
- for $i (1 .. $max) {
+ # Kill the condition, but leave any action.
+ $dbline{$i} =~ s/\A[^\0]*//;
- # If there's a breakpoint or action on this line ...
- if ( defined $dbline{$i} ) {
+ # Remove the entry entirely if there's no action left.
+ if ($dbline{$i} eq '') {
+ _remove_breakpoint_entry($filename, $i);
+ }
- # ... remove the breakpoint.
- $dbline{$i} =~ s/^[^\0]+//;
- if ( $dbline{$i} =~ s/^\0?$// ) {
+ return;
+}
- # Remove the entry altogether if no action is there.
- delete $dbline{$i};
- _delete_breakpoint_data_ref($file, $i);
- }
- } ## end if (defined $dbline{$i...
- } ## end for $i (1 .. $max)
+sub delete_breakpoint {
+ my $i = shift;
- # If, after we turn off the "there were breakpoints in this file"
- # bit, the entry in %had_breakpoints for this file is zero,
- # we should remove this file from the hash.
- if ( not $had_breakpoints{$file} &= ~1 ) {
- delete $had_breakpoints{$file};
- }
- } ## end for my $file (keys %had_breakpoints)
+ # If we got a line, delete just that one.
+ if ( defined($i) ) {
+ _delete_breakpoint_from_line($i);
+ }
+ # No line; delete them all.
+ else {
+ _delete_all_breakpoints();
+ }
- # Kill off all the other breakpoints that are waiting for files that
- # haven't been loaded yet.
- undef %postponed;
- undef %postponed_file;
- undef %break_on_load;
- } ## end else [ if (defined($i))
-} ## end sub delete_breakpoint
+ return;
+}
=head3 cmd_stop (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 cmd_M {
- &list_modules();
+ list_modules();
+
+ return;
}
=head3 C<cmd_o> - options (command)
=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