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;
# 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(*) {};
+ }
}
# These variables control the execution of 'dumpvar.pl'.
# without threads, $filename is not defined until DB::DB is called
foreach my $k (keys (%INC)) {
- share(\$main::{'_<'.$filename}) if defined $filename;
+ share(\$main::{'_<'.$filename}) if defined $filename;
};
# Command-line + PERLLIB:
if ($notty) {
$runnonstop = 1;
- share($runnonstop);
+ share($runnonstop);
}
=pod
# 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
} ## end if ($dbline{$line} && ...
}
+sub _DB__is_finished {
+ if ($finished and $level <= 1) {
+ end_report();
+ return 1;
+ }
+ else {
+ return;
+ }
+}
+
+sub _DB__read_next_cmd
+{
+ my ($tid) = @_;
+
+ # We have a terminal, or can get one ...
+ if (!$term) {
+ setterm();
+ }
+
+ # ... 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 {
# lock the debugger and get the thread id for the prompt
=cut
# If there's an action, do it now.
- $evalarg = $action, DB::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) {
- DB::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;
$evalarg = "\$^D = \$^D | \$DB::db_stop;\n$cmd";
# Run *our* eval that executes in the caller's context.
- DB::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) {
- DB::eval(@_);
+ DB::eval();
}
} # if ($single || $signal)
# Fix context DB::eval() wants to return an array, but
# we need a scalar here.
- my ($val) = join( "', '", DB::eval(@_) );
+ my ($val) = join( "', '", DB::eval() );
$val = ( ( defined $val ) ? "'$val'" : 'undef' );
# Did it change?
}
}
+sub _curr_line {
+ return $DB::dbline[$DB::line];
+}
+
sub _DB__grab_control
{
my $self = shift;
$self->prefix($DB::sub =~ /::/ ? "" : ($DB::package . '::'));
$self->append_to_prefix( "$DB::sub(${DB::filename}:" );
- $self->after( $DB::dbline[$DB::line] =~ /\n$/ ? '' : "\n" );
+ $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$DB::dbline[$DB::line]" . $self->after);
+ $self->position($self->prefix . "$DB::line):\n$DB::line:\t" . $self->_curr_line . $self->after);
$self->prefix("");
$self->infix(":\t");
}
$self->infix("):\t");
$self->position(
$self->prefix . $DB::line. $self->infix
- . $DB::dbline[$DB::line] . $self->after
+ . $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 ( my $i = $DB::line + 1 ; $i <= $DB::max && $DB::dbline[$i] == 0 ; ++$i )
+ for ( $i = $DB::line + 1 ; $i <= $DB::max && $line_i->() == 0 ; ++$i )
{ #{ vi
# Drop out on null statements, block closers, and comments.
- last if $DB::dbline[$i] =~ /^\s*[\;\}\#\n]/;
+ 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( $DB::dbline[$i] =~ /\n$/ ? '' : "\n" );
+ $self->after( $line_i->() =~ /\n$/ ? '' : "\n" );
# Next executable line.
- my $incr_pos = $self->prefix . $i . $self->infix . $DB::dbline[$i]
+ 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);
# 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)
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) = DB::eval(@_);
+ ($isa) = DB::eval();
no strict 'refs';
print join(
', ',
# Set up for DB::eval() - evaluate in *user* context.
$evalarg = $1;
# $evalarg = $2;
- my ($s) = DB::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( ' ', 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;
+ 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) = DB::eval(@_);
+ my ($val) = DB::eval();
$val = ( defined $val ) ? "'$val'" : 'undef';
# Save it.
https://perl5.git.perl.org / perl5.git / blobdiff