The scalar C<${"_<$filename"}> simply contains the string C<$filename>.
This is also the case for evaluated strings that contain subroutines, or
which are currently being executed. The $filename for C<eval>ed strings looks
-like C<(eval 34).
+like C<(eval 34)>.
=head1 DEBUGGER STARTUP
=item * 8 - Adds parameter information to messages, and overloaded stringify and tied FETCH is enabled on the printed arguments. Ignored if C<4> is not on.
-=item * 16 - Adds C<I<context> return from I<subname>: I<value>> messages on subroutine/eval exit. Ignored if C<4> is is not on.
+=item * 16 - Adds C<I<context> return from I<subname>: I<value>> messages on subroutine/eval exit. Ignored if C<4> is not on.
=back
use strict;
+use Cwd ();
+
+my $_initial_cwd;
+
BEGIN {eval 'use IO::Handle'}; # Needed for flush only? breaks under miniperl
BEGIN {
require feature;
$^V =~ /^v(\d+\.\d+)/;
feature->import(":$1");
+ $_initial_cwd = Cwd::getcwd();
}
# Debugger for Perl 5.00x; perl5db.pl patch level:
use vars qw($VERSION $header);
-$VERSION = '1.39_06';
+# bump to X.XX in blead, only use X.XX_XX in maint
+$VERSION = '1.50';
$header = "perl5db.pl version $VERSION";
# Since we're only saving $@, we only have to localize the array element
# that it will be stored in.
local $saved[0]; # Preserve the old value of $@
- eval { DB::save() };
+ eval { &DB::save };
# Now see whether we need to report an error back to the user.
if ($at) {
lock($DBGR);
print "Threads support enabled\n";
} else {
+ *lock = sub(*) {};
*share = sub(\[$@%]) {};
}
}
{
*get_fork_TTY = \&xterm_get_fork_TTY; # use the xterm version
}
+ elsif ( $ENV{TMUX} ) {
+ *get_fork_TTY = \&tmux_get_fork_TTY;
+ }
elsif ( $^O eq 'os2' ) { # If this is OS/2,
*get_fork_TTY = \&os2_get_fork_TTY; # use the OS/2 version
}
PERLDB_RESTART - flag only, contains no restart data itself.
PERLDB_HIST - command history, if it's available
PERLDB_ON_LOAD - breakpoints set by the rc file
- PERLDB_POSTPONE - subs that have been loaded/not executed, and have actions
+ PERLDB_POSTPONE - subs that have been loaded/not executed,
+ and have actions
PERLDB_VISITED - files that had breakpoints
PERLDB_FILE_... - breakpoints for a file
PERLDB_OPT - active options
our ($runnonstop);
+# Local autoflush to avoid rt#116769,
+# as calling IO::File methods causes an unresolvable loop
+# that results in debugger failure.
+sub _autoflush {
+ my $o = select($_[0]);
+ $|++;
+ select($o);
+}
+
if ($notty) {
$runnonstop = 1;
share($runnonstop);
undef $console;
}
-=item * Unix - use C</dev/tty>.
+=item * Unix - use F</dev/tty>.
=cut
$console = "con";
}
+=item * AmigaOS - use C<CONSOLE:>.
+
+=cut
+
+ elsif ( $^O eq 'amigaos' ) {
+ $console = "CONSOLE:";
+ }
+
=item * VMS - use C<sys$command>.
=cut
- else {
+ elsif ($^O eq 'VMS') {
+ $console = 'sys$command';
+ }
+
+# Keep this last.
- # everything else is ...
- $console = "sys\$command";
+ else {
+ _db_warn("Can't figure out your console, using stdin");
+ undef $console;
}
=pod
} ## end elsif (from if(defined $remoteport))
# Unbuffer DB::OUT. We need to see responses right away.
- $OUT->autoflush(1);
+ _autoflush($OUT);
# Line info goes to debugger output unless pointed elsewhere.
# Pointing elsewhere makes it possible for slave editors to
# see if we should stop. If so, remove the one-time sigil.
elsif ($stop) {
$evalarg = "\$DB::signal |= 1 if do {$stop}";
- DB::eval();
+ # The &-call is here to ascertain the mutability of @_.
+ &DB::eval;
# If the breakpoint is temporary, then delete its enabled status.
if ($dbline{$line} =~ s/;9($|\0)/$1/) {
_cancel_breakpoint_temp_enabled_status($filename, $line);
setterm();
}
- # ... and it belogs to this PID or we get one for this PID ...
+ # ... and it belongs to this PID or we get one for this PID ...
if ($term_pid != $$) {
resetterm(1);
}
= $obj->cmd_args =~ /\A(?:(\d*)\s*(.*))?\z/) {
# See if we've got the necessary support.
- if (!eval { require PadWalker; PadWalker->VERSION(0.08) }) {
+ if (!eval {
+ local @INC = @INC;
+ pop @INC if $INC[-1] eq '.';
+ require PadWalker; PadWalker->VERSION(0.08) }) {
my $Err = $@;
_db_warn(
$Err =~ /locate/
my @vars = split( ' ', $match_vars || '' );
# Find the pad.
- my $h = eval { PadWalker::peek_my( ( $match_level || 0 ) + 1 ) };
+ my $h = eval { PadWalker::peek_my( ( $match_level || 0 ) + 2 ) };
# Oops. Can't find it.
if (my $Err = $@) {
# If the pattern isn't null ...
if ( $inpat ne "" ) {
- # Turn of warn and die procesing for a bit.
+ # Turn off warn and die processing for a bit.
local $SIG{__DIE__};
local $SIG{__WARN__};
# Oops. Bad pattern. No biscuit.
# Print the eval error and go back for more
# commands.
- print $OUT "$@";
+ print {$OUT} "$@";
next CMD;
}
$obj->pat($inpat);
++$start;
# Wrap if we pass the last line.
- $start = 1 if ($start > $max);
+ if ($start > $max) {
+ $start = 1;
+ }
# Stop if we have gotten back to this line again,
last if ($start == $end);
if ($dbline[$start] =~ m/$pat/i) {
if ($slave_editor) {
# Handle proper escaping in the slave.
- print $OUT "\032\032$filename:$start:0\n";
+ print {$OUT} "\032\032$filename:$start:0\n";
}
else {
# Just print the line normally.
- print $OUT "$start:\t",$dbline[$start],"\n";
+ print {$OUT} "$start:\t",$dbline[$start],"\n";
}
# And quit since we found something.
last;
# R - restart execution.
# rerun - controlled restart execution.
if ($cmd_cmd eq 'rerun' or $cmd_params eq '') {
+
+ # Change directory to the initial current working directory on
+ # the script startup, so if the debugged program changed the
+ # directory, then we will still be able to find the path to the
+ # the program. (perl 5 RT #121509 ).
+ chdir ($_initial_cwd);
+
my @args = ($cmd_cmd eq 'R' ? restart() : rerun($cmd_params));
# Close all non-system fds for a clean restart. A more
if $pager =~ /^\|/
&& ( "" eq $SIG{PIPE} || "DEFAULT" eq $SIG{PIPE} );
- OUT->autoflush(1);
+ _autoflush(\*OUT);
# Save current filehandle, and put it back.
$obj->selected(scalar( select(OUT) ));
# Don't put it back if pager was a pipe.
open( OUT, ">&SAVEOUT" ) || _db_warn("Can't restore DB::OUT");
}
+ # Let Readline know about the new filehandles.
+ reset_IN_OUT( \*IN, \*OUT );
+
# Close filehandle pager was using, restore the normal one
# if necessary,
close(SAVEOUT);
return;
}
+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;
+}
+
# 't' is type.
# 'm' is method.
# 'v' is the value (i.e: method name or subroutine ref).
# 's' is subroutine.
-my %cmd_lookup =
+my %cmd_lookup;
+
+BEGIN
+{
+ %cmd_lookup =
(
'-' => { t => 'm', v => '_handle_dash_command', },
'.' => { t => 's', v => \&_DB__handle_dot_command, },
{ t => 's', v => \&_DB__handle_restart_and_rerun_commands, },
} qw(R rerun)),
(map { $_ => {t => 'm', v => '_handle_cmd_wrapper_commands' }, }
- qw(a A b B e E h i l L M o O P v w W)),
+ qw(a A b B e E h i l L M o O v w W)),
);
+};
sub DB {
# Last line in the program.
$max = $#dbline;
- _DB__determine_if_we_should_break(@_);
+ # The &-call is here to ascertain the mutability of @_.
+ &_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 ...
- $obj->_DB__handle_watch_expressions(@_);
+ _DB__handle_watch_expressions($obj);
=head2 C<watchfunction()>
# If there's an action, do it now.
if ($action) {
$evalarg = $action;
- DB::eval();
+ # The &-call is here to ascertain the mutability of @_.
+ &DB::eval;
}
# Are we nested another level (e.g., did we evaluate a function
# Do any pre-prompt actions.
foreach $evalarg (@$pre) {
- DB::eval();
+ # The &-call is here to ascertain the mutability of @_.
+ &DB::eval;
}
# Complain about too much recursion if we passed the limit.
=head4 C<$rc> - Recall command
Manages the commands in C<@hist> (which is created if C<Term::ReadLine> reports
-that the terminal supports history). It find the the command required, puts it
+that the terminal supports history). It finds the command required, puts it
into C<$cmd>, and redoes the loop to execute it.
=cut
} # PIPE:
+ # trace an expression
+ $cmd =~ s/^t\s/\$DB::trace |= 1;\n/;
+
# Make sure the flag that says "the debugger's running" is
# still on, to make sure we get control again.
$evalarg = "\$^D = \$^D | \$DB::db_stop;\n$cmd";
# Run *our* eval that executes in the caller's context.
- DB::eval();
+ # The &-call is here to ascertain the mutability of @_.
+ &DB::eval;
# Turn off the one-time-dump stuff now.
if ($onetimeDump) {
# Evaluate post-prompt commands.
foreach $evalarg (@$post) {
- DB::eval();
+ # The &-call is here to ascertain the mutability of @_.
+ &DB::eval;
}
} # if ($single || $signal)
();
} ## end sub DB
+# Because DB::Obj is used above,
+#
+# my $obj = DB::Obj->new(
+#
+# The following package declaration must come before that,
+# or else runtime errors will occur with
+#
+# PERLDB_OPTS="autotrace nonstop"
+#
+# ( rt#116771 )
+BEGIN {
+
package DB::Obj;
sub new {
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) = @_;
EOP
# Set the DB::eval context appropriately.
+ # At program termination disable any user actions.
+ $DB::action = undef;
+
$DB::package = 'main';
$DB::usercontext = DB::_calc_usercontext($DB::package);
} ## end elsif ($package eq 'DB::fake')
# man, perldoc, doc - show manual pages.
if (my ($man_page)
= $DB::cmd =~ /\A(?:man|(?:perl)?doc)\b(?:\s+([^(]*))?\z/) {
- runman($man_page);
+ DB::runman($man_page);
next CMD;
}
return;
}
+} ## end DB::Obj
+
package DB;
# The following code may be executed now:
}
sub DB::sub {
- # Do not use a regex in this subroutine -> results in corrupted memory
- # See: [perl #66110]
-
# lock ourselves under threads
lock($DBGR);
$stack[-1] = $single;
# Turn off all flags except single-stepping.
- $single &= 1;
+ # Use local so the single-step value is popped back off the
+ # stack for us.
+ local $single = $single & 1;
# If we've gotten really deeply recursed, turn on the flag that will
# make us stop with the 'deep recursion' message.
# If frame messages are on ...
_print_frame_message($al);
- # Pop the single-step value back off the stack.
- $single |= $stack[ $stack_depth-- ];
-
# call the original lvalue sub.
&$sub;
}
my $line = shift;
foreach my $isa ( split( /\s+/, $line ) ) {
$evalarg = $isa;
- ($isa) = DB::eval();
+ # The &-call is here to ascertain the mutability of @_.
+ ($isa) = &DB::eval;
no strict 'refs';
print join(
', ',
=cut
-sub cmd_l {
- my $current_line = $line;
- my $cmd = shift;
- my $line = shift;
+sub _min {
+ my $min = shift;
+ foreach my $v (@_) {
+ if ($min > $v) {
+ $min = $v;
+ }
+ }
+ return $min;
+}
- # If this is '-something', delete any spaces after the dash.
- $line =~ s/^-\s*$/-/;
+sub _max {
+ my $max = shift;
+ foreach my $v (@_) {
+ if ($max < $v) {
+ $max = $v;
+ }
+ }
+ return $max;
+}
- # If the line is '$something', assume this is a scalar containing a
- # line number.
- if ( $line =~ /^(\$.*)/s ) {
+sub _minify_to_max {
+ my $ref = shift;
- # Set up for DB::eval() - evaluate in *user* context.
- $evalarg = $1;
- # $evalarg = $2;
- my ($s) = DB::eval();
+ $$ref = _min($$ref, $max);
- # Ooops. Bad scalar.
- if ($@) {
- print {$OUT} "Error: $@\n";
- next CMD;
- }
+ return;
+}
- # Good scalar. If it's a reference, find what it points to.
- $s = CvGV_name($s);
- print {$OUT} "Interpreted as: $1 $s\n";
- $line = "$1 $s";
+sub _cmd_l_handle_var_name {
+ my $var_name = shift;
- # Call self recursively to really do the command.
- cmd_l( 'l', $s );
- } ## end if ($line =~ /^(\$.*)/s)
+ $evalarg = $var_name;
- # l name. Try to find a sub by that name.
- elsif ( ($subname) = $line =~ /\A([\':A-Za-z_][\':\w]*(?:\[.*\])?)/s ) {
- my $s = $subname;
+ my ($s) = DB::eval();
+
+ # Ooops. Bad scalar.
+ if ($@) {
+ print {$OUT} "Error: $@\n";
+ next CMD;
+ }
- # De-Perl4.
- $subname =~ s/\'/::/;
+ # Good scalar. If it's a reference, find what it points to.
+ $s = CvGV_name($s);
+ print {$OUT} "Interpreted as: $1 $s\n";
+ $line = "$1 $s";
- # Put it in this package unless it starts with ::.
- $subname = $package . "::" . $subname unless $subname =~ /::/;
+ # Call self recursively to really do the command.
+ return _cmd_l_main( $s );
+}
- # Put it in CORE::GLOBAL if t doesn't start with :: and
- # it doesn't live in this package and it lives in CORE::GLOBAL.
- $subname = "CORE::GLOBAL::$s"
- if not defined &$subname
- and $s !~ /::/
- and defined &{"CORE::GLOBAL::$s"};
+sub _cmd_l_handle_subname {
- # Put leading '::' names into 'main::'.
- $subname = "main" . $subname if substr( $subname, 0, 2 ) eq "::";
+ my $s = $subname;
- # Get name:start-stop from find_sub, and break this up at
- # colons.
- my @pieces = split( /:/, find_sub($subname) || $sub{$subname} );
+ # De-Perl4.
+ $subname =~ s/\'/::/;
- # Pull off start-stop.
- my $subrange = pop @pieces;
+ # Put it in this package unless it starts with ::.
+ $subname = $package . "::" . $subname unless $subname =~ /::/;
- # If the name contained colons, the split broke it up.
- # Put it back together.
- $file = join( ':', @pieces );
+ # Put it in CORE::GLOBAL if t doesn't start with :: and
+ # it doesn't live in this package and it lives in CORE::GLOBAL.
+ $subname = "CORE::GLOBAL::$s"
+ if not defined &$subname
+ and $s !~ /::/
+ and defined &{"CORE::GLOBAL::$s"};
- # If we're not in that file, switch over to it.
- if ( $file ne $filename ) {
- print $OUT "Switching to file '$file'.\n"
- unless $slave_editor;
+ # Put leading '::' names into 'main::'.
+ $subname = "main" . $subname if substr( $subname, 0, 2 ) eq "::";
- # Switch debugger's magic structures.
- *dbline = $main::{ '_<' . $file };
- $max = $#dbline;
- $filename = $file;
- } ## end if ($file ne $filename)
+ # Get name:start-stop from find_sub, and break this up at
+ # colons.
+ my @pieces = split( /:/, find_sub($subname) || $sub{$subname} );
- # Subrange is 'start-stop'. If this is less than a window full,
- # swap it to 'start+', which will list a window from the start point.
- if ($subrange) {
- if ( eval($subrange) < -$window ) {
- $subrange =~ s/-.*/+/;
- }
+ # Pull off start-stop.
+ my $subrange = pop @pieces;
- # Call self recursively to list the range.
- $line = $subrange;
- cmd_l( 'l', $subrange );
- } ## end if ($subrange)
+ # If the name contained colons, the split broke it up.
+ # Put it back together.
+ $file = join( ':', @pieces );
- # Couldn't find it.
- else {
- print $OUT "Subroutine $subname not found.\n";
+ # If we're not in that file, switch over to it.
+ if ( $file ne $filename ) {
+ if (! $slave_editor) {
+ print {$OUT} "Switching to file '$file'.\n";
}
- } ## end elsif ($line =~ /^([\':A-Za-z_][\':\w]*(\[.*\])?)/s)
- # Bare 'l' command.
- elsif ( $line !~ /\S/ ) {
+ # Switch debugger's magic structures.
+ *dbline = $main::{ '_<' . $file };
+ $max = $#dbline;
+ $filename = $file;
+ } ## end if ($file ne $filename)
+
+ # Subrange is 'start-stop'. If this is less than a window full,
+ # swap it to 'start+', which will list a window from the start point.
+ if ($subrange) {
+ if ( eval($subrange) < -$window ) {
+ $subrange =~ s/-.*/+/;
+ }
- # Compute new range to list.
- $incr = $window - 1;
- $line = $start . '-' . ( $start + $incr );
+ # Call self recursively to list the range.
+ return _cmd_l_main( $subrange );
+ } ## end if ($subrange)
- # Recurse to do it.
- cmd_l( 'l', $line );
+ # Couldn't find it.
+ else {
+ print {$OUT} "Subroutine $subname not found.\n";
+ return;
}
+}
- # l [start]+number_of_lines
- elsif ( my ($new_start, $new_incr) = $line =~ /\A(\d*)\+(\d*)\z/ ) {
+sub _cmd_l_empty {
+ # Compute new range to list.
+ $incr = $window - 1;
- # Don't reset start for 'l +nnn'.
- $start = $new_start if $new_start;
+ # Recurse to do it.
+ return _cmd_l_main( $start . '-' . ( $start + $incr ) );
+}
- # Increment for list. Use window size if not specified.
- # (Allows 'l +' to work.)
- $incr = $new_incr;
- $incr = $window - 1 unless $incr;
+sub _cmd_l_plus {
+ my ($new_start, $new_incr) = @_;
- # Create a line range we'll understand, and recurse to do it.
- $line = $start . '-' . ( $start + $incr );
- cmd_l( 'l', $line );
- } ## end elsif ($line =~ /^(\d*)\+(\d*)$/)
+ # Don't reset start for 'l +nnn'.
+ $start = $new_start if $new_start;
- # l start-stop or l start,stop
- elsif ( $line =~ /^((-?[\d\$\.]+)([-,]([\d\$\.]+))?)?/ ) {
+ # Increment for list. Use window size if not specified.
+ # (Allows 'l +' to work.)
+ $incr = $new_incr || ($window - 1);
+
+ # Create a line range we'll understand, and recurse to do it.
+ return _cmd_l_main( $start . '-' . ( $start + $incr ) );
+}
+
+sub _cmd_l_calc_initial_end_and_i {
+ my ($spec, $start_match, $end_match) = @_;
+
+ # Determine end point; use end of file if not specified.
+ my $end = ( !defined $start_match ) ? $max :
+ ( $end_match ? $end_match : $start_match );
+
+ # Go on to the end, and then stop.
+ _minify_to_max(\$end);
- # Determine end point; use end of file if not specified.
- my $end = ( !defined $2 ) ? $max : ( $4 ? $4 : $2 );
+ # Determine start line.
+ my $i = $start_match;
- # Go on to the end, and then stop.
- $end = $max if $end > $max;
+ if ($i eq '.') {
+ $i = $spec;
+ }
+
+ $i = _max($i, 1);
+
+ $incr = $end - $i;
+
+ return ($end, $i);
+}
+
+sub _cmd_l_range {
+ my ($spec, $current_line, $start_match, $end_match) = @_;
+
+ my ($end, $i) =
+ _cmd_l_calc_initial_end_and_i($spec, $start_match, $end_match);
+
+ # If we're running under a slave editor, force it to show the lines.
+ if ($slave_editor) {
+ print {$OUT} "\032\032$filename:$i:0\n";
+ $i = $end;
+ }
+ # We're doing it ourselves. We want to show the line and special
+ # markers for:
+ # - the current line in execution
+ # - whether a line is breakable or not
+ # - whether a line has a break or not
+ # - whether a line has an action or not
+ else {
+ I_TO_END:
+ for ( ; $i <= $end ; $i++ ) {
+
+ # Check for breakpoints and actions.
+ my ( $stop, $action );
+ if ($dbline{$i}) {
+ ( $stop, $action ) = split( /\0/, $dbline{$i} );
+ }
+
+ # ==> if this is the current line in execution,
+ # : if it's breakable.
+ my $arrow =
+ ( $i == $current_line and $filename eq $filename_ini )
+ ? '==>'
+ : ( $dbline[$i] + 0 ? ':' : ' ' );
+
+ # Add break and action indicators.
+ $arrow .= 'b' if $stop;
+ $arrow .= 'a' if $action;
- # Determine start line.
- my $i = $2;
- $i = $line if $i eq '.';
- $i = 1 if $i < 1;
- $incr = $end - $i;
+ # Print the line.
+ print {$OUT} "$i$arrow\t", $dbline[$i];
- # If we're running under a slave editor, force it to show the lines.
- if ($slave_editor) {
- print $OUT "\032\032$filename:$i:0\n";
- $i = $end;
+ # Move on to the next line. Drop out on an interrupt.
+ if ($signal) {
+ $i++;
+ last I_TO_END;
+ }
+ } ## end for (; $i <= $end ; $i++)
+
+ # Line the prompt up; print a newline if the last line listed
+ # didn't have a newline.
+ if ($dbline[ $i - 1 ] !~ /\n\z/) {
+ print {$OUT} "\n";
}
+ } ## end else [ if ($slave_editor)
- # We're doing it ourselves. We want to show the line and special
- # markers for:
- # - the current line in execution
- # - whether a line is breakable or not
- # - whether a line has a break or not
- # - whether a line has an action or not
- else {
- for ( ; $i <= $end ; $i++ ) {
+ # Save the point we last listed to in case another relative 'l'
+ # command is desired. Don't let it run off the end.
+ $start = $i;
+ _minify_to_max(\$start);
- # Check for breakpoints and actions.
- my ( $stop, $action );
- ( $stop, $action ) = split( /\0/, $dbline{$i} )
- if $dbline{$i};
+ return;
+}
- # ==> if this is the current line in execution,
- # : if it's breakable.
- my $arrow =
- ( $i == $current_line and $filename eq $filename_ini )
- ? '==>'
- : ( $dbline[$i] + 0 ? ':' : ' ' );
+sub _cmd_l_main {
+ my $spec = shift;
- # Add break and action indicators.
- $arrow .= 'b' if $stop;
- $arrow .= 'a' if $action;
+ # If this is '-something', delete any spaces after the dash.
+ $spec =~ s/\A-\s*\z/-/;
- # Print the line.
- print $OUT "$i$arrow\t", $dbline[$i];
-
- # Move on to the next line. Drop out on an interrupt.
- $i++, last if $signal;
- } ## end for (; $i <= $end ; $i++)
-
- # Line the prompt up; print a newline if the last line listed
- # didn't have a newline.
- print $OUT "\n" unless $dbline[ $i - 1 ] =~ /\n$/;
- } ## end else [ if ($slave_editor)
-
- # Save the point we last listed to in case another relative 'l'
- # command is desired. Don't let it run off the end.
- $start = $i;
- $start = $max if $start > $max;
- } ## end elsif ($line =~ /^((-?[\d\$\.]+)([-,]([\d\$\.]+))?)?/)
+ # If the line is '$something', assume this is a scalar containing a
+ # line number.
+ # Set up for DB::eval() - evaluate in *user* context.
+ if ( my ($var_name) = $spec =~ /\A(\$.*)/s ) {
+ return _cmd_l_handle_var_name($var_name);
+ }
+ # l name. Try to find a sub by that name.
+ elsif ( ($subname) = $spec =~ /\A([\':A-Za-z_][\':\w]*(?:\[.*\])?)/s ) {
+ return _cmd_l_handle_subname();
+ }
+ # Bare 'l' command.
+ elsif ( $spec !~ /\S/ ) {
+ return _cmd_l_empty();
+ }
+ # l [start]+number_of_lines
+ elsif ( my ($new_start, $new_incr) = $spec =~ /\A(\d*)\+(\d*)\z/ ) {
+ return _cmd_l_plus($new_start, $new_incr);
+ }
+ # l start-stop or l start,stop
+ elsif (my ($s, $e) = $spec =~ /^(?:(-?[\d\$\.]+)(?:[-,]([\d\$\.]+))?)?/ ) {
+ return _cmd_l_range($spec, $line, $s, $e);
+ }
+
+ return;
} ## end sub cmd_l
+sub cmd_l {
+ my (undef, $line) = @_;
+
+ return _cmd_l_main($line);
+}
+
=head3 C<cmd_L> - list breakpoints, actions, and watch expressions (command)
To list breakpoints, the command has to look determine where all of them are
=cut
-sub cmd_L {
- my $cmd = shift;
-
+sub _cmd_L_calc_arg {
# If no argument, list everything. Pre-5.8.0 version always lists
# everything
my $arg = shift || 'abw';
$arg = 'abw';
}
- # See what is wanted.
- my $action_wanted = ( $arg =~ /a/ ) ? 1 : 0;
- my $break_wanted = ( $arg =~ /b/ ) ? 1 : 0;
- my $watch_wanted = ( $arg =~ /w/ ) ? 1 : 0;
+ return $arg;
+}
- # Breaks and actions are found together, so we look in the same place
- # for both.
- if ( $break_wanted or $action_wanted ) {
+sub _cmd_L_calc_wanted_flags {
+ my $arg = _cmd_L_calc_arg(shift);
- # Look in all the files with breakpoints...
- for my $file ( keys %had_breakpoints ) {
+ return (map { index($arg, $_) >= 0 ? 1 : 0 } qw(a b w));
+}
- # Temporary switch to this file.
- local *dbline = $main::{ '_<' . $file };
- # Set up to look through the whole file.
- $max = $#dbline;
- my $was; # Flag: did we print something
- # in this file?
+sub _cmd_L_handle_breakpoints {
+ my ($handle_db_line) = @_;
- # For each line in the file ...
- for my $i (1 .. $max) {
+ BREAKPOINTS_SCAN:
+ # Look in all the files with breakpoints...
+ for my $file ( keys %had_breakpoints ) {
- # We've got something on this line.
- if ( defined $dbline{$i} ) {
+ # Temporary switch to this file.
+ local *dbline = $main::{ '_<' . $file };
- # Print the header if we haven't.
- print $OUT "$file:\n" unless $was++;
+ # Set up to look through the whole file.
+ $max = $#dbline;
+ my $was; # Flag: did we print something
+ # in this file?
- # Print the line.
- print $OUT " $i:\t", $dbline[$i];
+ # For each line in the file ...
+ for my $i (1 .. $max) {
- # Pull out the condition and the action.
- my ( $stop, $action ) = split( /\0/, $dbline{$i} );
+ # We've got something on this line.
+ if ( defined $dbline{$i} ) {
- # Print the break if there is one and it's wanted.
- print $OUT " break if (", $stop, ")\n"
- if $stop
- and $break_wanted;
+ # Print the header if we haven't.
+ if (not $was++) {
+ print {$OUT} "$file:\n";
+ }
- # Print the action if there is one and it's wanted.
- print $OUT " action: ", $action, "\n"
- if $action
- and $action_wanted;
+ # Print the line.
+ print {$OUT} " $i:\t", $dbline[$i];
- # Quit if the user hit interrupt.
- last if $signal;
- } ## end if (defined $dbline{$i...
- } ## end for my $i (1 .. $max)
- } ## end for my $file (keys %had_breakpoints)
- } ## end if ($break_wanted or $action_wanted)
+ $handle_db_line->($dbline{$i});
+
+ # Quit if the user hit interrupt.
+ if ($signal) {
+ last BREAKPOINTS_SCAN;
+ }
+ } ## end if (defined $dbline{$i...
+ } ## end for my $i (1 .. $max)
+ } ## end for my $file (keys %had_breakpoints)
+
+ return;
+}
+
+sub _cmd_L_handle_postponed_breakpoints {
+ my ($handle_db_line) = @_;
+
+ print {$OUT} "Postponed breakpoints in files:\n";
+
+ POSTPONED_SCANS:
+ for my $file ( keys %postponed_file ) {
+ my $db = $postponed_file{$file};
+ print {$OUT} " $file:\n";
+ for my $line ( sort { $a <=> $b } keys %$db ) {
+ print {$OUT} " $line:\n";
+
+ $handle_db_line->($db->{$line});
+
+ if ($signal) {
+ last POSTPONED_SCANS;
+ }
+ }
+ if ($signal) {
+ last POSTPONED_SCANS;
+ }
+ }
+
+ return;
+}
+
+
+sub cmd_L {
+ my $cmd = shift;
+
+ my ($action_wanted, $break_wanted, $watch_wanted) =
+ _cmd_L_calc_wanted_flags(shift);
+
+ my $handle_db_line = sub {
+ my ($l) = @_;
+
+ my ( $stop, $action ) = split( /\0/, $l );
+
+ if ($stop and $break_wanted) {
+ print {$OUT} " break if (", $stop, ")\n"
+ }
+
+ if ($action && $action_wanted) {
+ print {$OUT} " action: ", $action, "\n"
+ }
+
+ return;
+ };
+
+ # Breaks and actions are found together, so we look in the same place
+ # for both.
+ if ( $break_wanted or $action_wanted ) {
+ _cmd_L_handle_breakpoints($handle_db_line);
+ }
# Look for breaks in not-yet-compiled subs:
if ( %postponed and $break_wanted ) {
- print $OUT "Postponed breakpoints in subroutines:\n";
+ print {$OUT} "Postponed breakpoints in subroutines:\n";
my $subname;
+ SUBS_SCAN:
for $subname ( keys %postponed ) {
- print $OUT " $subname\t$postponed{$subname}\n";
- last if $signal;
+ print {$OUT} " $subname\t$postponed{$subname}\n";
+ if ($signal) {
+ last SUBS_SCAN;
+ }
}
} ## end if (%postponed and $break_wanted)
# If there are any, list them.
if ( @have and ( $break_wanted or $action_wanted ) ) {
- print $OUT "Postponed breakpoints in files:\n";
- for my $file ( keys %postponed_file ) {
- my $db = $postponed_file{$file};
- print $OUT " $file:\n";
- for my $line ( sort { $a <=> $b } keys %$db ) {
- print $OUT " $line:\n";
- my ( $stop, $action ) = split( /\0/, $$db{$line} );
- print $OUT " break if (", $stop, ")\n"
- if $stop
- and $break_wanted;
- print $OUT " action: ", $action, "\n"
- if $action
- and $action_wanted;
- last if $signal;
- } ## end for $line (sort { $a <=>...
- last if $signal;
- } ## end for $file (keys %postponed_file)
+ _cmd_L_handle_postponed_breakpoints($handle_db_line);
} ## end if (@have and ($break_wanted...
+
if ( %break_on_load and $break_wanted ) {
print {$OUT} "Breakpoints on load:\n";
BREAK_ON_LOAD: for my $filename ( keys %break_on_load ) {
last BREAK_ON_LOAD if $signal;
}
} ## end if (%break_on_load and...
+
if ($watch_wanted and ( $trace & 2 )) {
print {$OUT} "Watch-expressions:\n" if @to_watch;
TO_WATCH: for my $expr (@to_watch) {
last TO_WATCH if $signal;
}
}
+
+ return;
} ## end sub cmd_L
=head3 C<cmd_M> - list modules (command)
# in the user's context. This version can handle expressions which
# return a list value.
$evalarg = $expr;
- my ($val) = join( ' ', DB::eval() );
+ # The &-call is here to ascertain the mutability of @_.
+ my ($val) = join( ' ', &DB::eval);
$val = ( defined $val ) ? "'$val'" : 'undef';
# Save the current value of the expression.
} ## end foreach (@to_watch)
# We don't bother to turn watching off because
- # a) we don't want to stop calling watchfunction() it it exists
+ # a) we don't want to stop calling watchfunction() if it exists
# b) foreach over a null list doesn't do anything anyway
} ## end elsif ($expr =~ /^(\S.*)/)
resetterm(1) if $LINEINFO eq $OUT and $term_pid != $$;
local $\ = '';
local $, = '';
- print $LINEINFO @_;
+ # $LINEINFO may be undef if $noTTY is set or some other issue.
+ if ($LINEINFO)
+ {
+ print {$LINEINFO} @_;
+ }
} ## end sub print_lineinfo
=head2 C<postponed_sub>
# Drop out if the user has lost interest and hit control-C.
last if $signal;
- # Set the separator so arrys print nice.
+ # Set the separator so arrays print nice.
local $" = ', ';
# Grab and stringify the arguments if they are there.
=cut
+sub _dump_trace_calc_saved_single_arg
+{
+ my ($nothard, $arg) = @_;
+
+ my $type;
+ if ( not defined $arg ) { # undefined parameter
+ return "undef";
+ }
+
+ elsif ( $nothard and tied $arg ) { # tied parameter
+ return "tied";
+ }
+ elsif ( $nothard and $type = ref $arg ) { # reference
+ return "ref($type)";
+ }
+ else { # can be stringified
+ local $_ =
+ "$arg"; # Safe to stringify now - should not call f().
+
+ # Backslash any single-quotes or backslashes.
+ s/([\'\\])/\\$1/g;
+
+ # Single-quote it unless it's a number or a colon-separated
+ # name.
+ s/(.*)/'$1'/s
+ unless /^(?: -?[\d.]+ | \*[\w:]* )$/x;
+
+ # Turn high-bit characters into meta-whatever, and controls into like
+ # '^D'.
+ require 'meta_notation.pm';
+ $_ = _meta_notation($_) if /[[:^print:]]/a;
+
+ return $_;
+ }
+}
+
+sub _dump_trace_calc_save_args {
+ my ($nothard) = @_;
+
+ return [
+ map { _dump_trace_calc_saved_single_arg($nothard, $_) } @args
+ ];
+}
+
sub dump_trace {
# How many levels to skip.
# These variables are used to capture output from caller();
my ( $p, $file, $line, $sub, $h, $context );
- my ( $e, $r, @a, @sub, $args );
+ my ( $e, $r, @sub, $args );
# XXX Okay... why'd we do that?
my $nothard = not $frame & 8;
{
# Go through the arguments and save them for later.
- @a = ();
- for my $arg (@args) {
- my $type;
- if ( not defined $arg ) { # undefined parameter
- push @a, "undef";
- }
-
- elsif ( $nothard and tied $arg ) { # tied parameter
- push @a, "tied";
- }
- elsif ( $nothard and $type = ref $arg ) { # reference
- push @a, "ref($type)";
- }
- else { # can be stringified
- local $_ =
- "$arg"; # Safe to stringify now - should not call f().
-
- # Backslash any single-quotes or backslashes.
- s/([\'\\])/\\$1/g;
-
- # Single-quote it unless it's a number or a colon-separated
- # name.
- s/(.*)/'$1'/s
- unless /^(?: -?[\d.]+ | \*[\w:]* )$/x;
-
- # Turn high-bit characters into meta-whatever.
- s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg;
-
- # Turn control characters into ^-whatever.
- s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg;
-
- push( @a, $_ );
- } ## end else [ if (not defined $arg)
- } ## end for $arg (@args)
+ my $save_args = _dump_trace_calc_save_args($nothard);
# If context is true, this is array (@)context.
# If context is false, this is scalar ($) context.
# if the sub has args ($h true), make an anonymous array of the
# dumped args.
- $args = $h ? [@a] : undef;
+ $args = $h ? $save_args : undef;
# remove trailing newline-whitespace-semicolon-end of line sequence
# from the eval text, if any.
# We save, change, then restore STDIN and STDOUT to avoid fork() since
# some non-Unix systems can do system() but have problems with fork().
- open( SAVEIN, "<&STDIN" ) || db_warn("Can't save STDIN");
- open( SAVEOUT, ">&STDOUT" ) || db_warn("Can't save STDOUT");
- open( STDIN, "<&IN" ) || db_warn("Can't redirect STDIN");
- open( STDOUT, ">&OUT" ) || db_warn("Can't redirect STDOUT");
+ open( SAVEIN, "<&STDIN" ) || _db_warn("Can't save STDIN");
+ open( SAVEOUT, ">&STDOUT" ) || _db_warn("Can't save STDOUT");
+ open( STDIN, "<&IN" ) || _db_warn("Can't redirect STDIN");
+ open( STDOUT, ">&OUT" ) || _db_warn("Can't redirect STDOUT");
# XXX: using csh or tcsh destroys sigint retvals!
system(@_);
- open( STDIN, "<&SAVEIN" ) || db_warn("Can't restore STDIN");
- open( STDOUT, ">&SAVEOUT" ) || db_warn("Can't restore STDOUT");
+ open( STDIN, "<&SAVEIN" ) || _db_warn("Can't restore STDIN");
+ open( STDOUT, ">&SAVEOUT" ) || _db_warn("Can't restore STDOUT");
close(SAVEIN);
close(SAVEOUT);
# most of the $? crud was coping with broken cshisms
if ( $? >> 8 ) {
- db_warn( "(Command exited ", ( $? >> 8 ), ")\n" );
+ _db_warn( "(Command exited ", ( $? >> 8 ), ")\n" );
}
elsif ($?) {
- db_warn(
+ _db_warn(
"(Command died of SIG#",
( $? & 127 ),
( ( $? & 128 ) ? " -- core dumped" : "" ),
open( OUT, ">$o" ) or die "Cannot open TTY '$o' for write: $!";
$IN = \*IN;
$OUT = \*OUT;
- $OUT->autoflush(1);
+ _autoflush($OUT);
} ## end if ($tty)
# We don't have a TTY - try to find one via Term::Rendezvous.
return $tty;
}
+=head3 C<tmux_get_fork_TTY>
+
+Creates a split window for subprocesses when a process running under the
+perl debugger in Tmux forks.
+
+=cut
+
+sub tmux_get_fork_TTY {
+ return unless $ENV{TMUX};
+
+ my $pipe;
+
+ my $status = open $pipe, '-|', 'tmux', 'split-window',
+ '-P', '-F', '#{pane_tty}', 'sleep 100000';
+
+ if ( !$status ) {
+ return;
+ }
+
+ my $tty = <$pipe>;
+ close $pipe;
+
+ if ( $tty ) {
+ chomp $tty;
+
+ if ( !defined $term ) {
+ require Term::ReadLine;
+ if ( !$rl ) {
+ $term = Term::ReadLine::Stub->new( 'perldb', $IN, $OUT );
+ }
+ else {
+ $term = Term::ReadLine->new( 'perldb', $IN, $OUT );
+ }
+ }
+ }
+
+ return $tty;
+}
+
=head2 C<create_IN_OUT($flags)>
Create a new pair of filehandles, pointing to a new TTY. If impossible,
Set_list packages up items to be stored in a set of environment variables
(VAR_n, containing the number of items, and VAR_0, VAR_1, etc., containing
the values). Values outside the standard ASCII charset are stored by encoding
-then as hexadecimal values.
+them as hexadecimal values.
=cut
for my $i ( 0 .. $#list ) {
$val = $list[$i];
$val =~ s/\\/\\\\/g;
- $val =~ s/([\0-\37\177\200-\377])/"\\0x" . unpack('H2',$1)/eg;
+ no warnings 'experimental::regex_sets';
+ $val =~ s/ ( (?[ [\000-\xFF] & [:^print:] ]) ) /
+ "\\0x" . unpack('H2',$1)/xaeg;
$ENV{"${stem}_$i"} = $val;
} ## end for $i (0 .. $#list)
} ## end sub set_list
}
# Unbuffer the output filehandle.
- $OUT->autoflush(1);
+ _autoflush($OUT);
# Point LINEINFO to the same output filehandle if it was there before.
$LINEINFO = $OUT if $switch_li;
open ($new_lineinfo_fh , $stream )
or _db_warn("Cannot open '$stream' for write");
$LINEINFO = $new_lineinfo_fh;
- $LINEINFO->autoflush(1);
+ _autoflush($LINEINFO);
}
return $lineinfo;
# wide. If it's wider than that, an extra space will be added.
$help_str =~ s{
^ # only matters at start of line
- ( \040{4} | \t )* # some subcommands are indented
+ ( \ {4} | \t )* # some subcommands are indented
( < ? # so <CR> works
[BI] < [^\t\n] + ) # find an eeevil ornament
( \t+ ) # original separation, discarded
=cut
-my %_is_in_pods = (map { $_ => 1 }
- qw(
- 5004delta
- 5005delta
- 561delta
- 56delta
- 570delta
- 571delta
- 572delta
- 573delta
- 58delta
- 581delta
- 582delta
- 583delta
- 584delta
- 590delta
- 591delta
- 592delta
- aix
- amiga
- apio
- api
- artistic
- book
- boot
- bot
- bs2000
- call
- ce
- cheat
- clib
- cn
- compile
- cygwin
- data
- dbmfilter
- debguts
- debtut
- debug
- delta
- dgux
- diag
- doc
- dos
- dsc
- ebcdic
- embed
- faq1
- faq2
- faq3
- faq4
- faq5
- faq6
- faq7
- faq8
- faq9
- faq
- filter
- fork
- form
- freebsd
- func
- gpl
- guts
- hack
- hist
- hpux
- hurd
- intern
- intro
- iol
- ipc
- irix
- jp
- ko
- lexwarn
- locale
- lol
- macos
- macosx
- modinstall
- modlib
- mod
- modstyle
- netware
- newmod
- number
- obj
- opentut
- op
- os2
- os390
- os400
- packtut
- plan9
- pod
- podspec
- port
- qnx
- ref
- reftut
- re
- requick
- reref
- retut
- run
- sec
- solaris
- style
- sub
- syn
- thrtut
- tie
- toc
- todo
- tooc
- toot
- trap
- tru64
- tw
- unicode
- uniintro
- util
- uts
- var
- vms
- vos
- win32
- xs
- xstut
- )
-);
-
sub runman {
my $page = shift;
unless ($page) {
$page = 'perl' if lc($page) eq 'help';
require Config;
- my $man1dir = $Config::Config{'man1dir'};
- my $man3dir = $Config::Config{'man3dir'};
+ my $man1dir = $Config::Config{man1direxp};
+ my $man3dir = $Config::Config{man3direxp};
for ( $man1dir, $man3dir ) { s#/[^/]*\z## if /\S/ }
my $manpath = '';
$manpath .= "$man1dir:" if $man1dir =~ /\S/;
chop $manpath if $manpath;
# harmless if missing, I figure
- my $oldpath = $ENV{MANPATH};
- $ENV{MANPATH} = $manpath if $manpath;
+ local $ENV{MANPATH} = $manpath if $manpath;
my $nopathopt = $^O =~ /dunno what goes here/;
if (
CORE::system(
)
{
unless ( $page =~ /^perl\w/ ) {
-# do it this way because its easier to slurp in to keep up to date - clunky though.
- if (exists($_is_in_pods{$page})) {
+ # Previously the debugger contained a list which it slurped in,
+ # listing the known "perl" manpages. However, it was out of date,
+ # with errors both of omission and inclusion. This approach is
+ # considerably less complex. The failure mode on a butchered
+ # install is simply that the user has to run man or perldoc
+ # "manually" with the full manpage name.
+
+ # There is a list of $^O values in installperl to determine whether
+ # the directory is 'pods' or 'pod'. However, we can avoid tight
+ # coupling to that by simply checking the "non-standard" 'pods'
+ # first.
+ my $pods = "$Config::Config{privlibexp}/pods";
+ $pods = "$Config::Config{privlibexp}/pod"
+ unless -d $pods;
+ if (-f "$pods/perl$page.pod") {
CORE::system( $doccmd,
( ( $manpath && !$nopathopt ) ? ( "-M", $manpath ) : () ),
"perl$page" );
}
}
} ## end if (CORE::system($doccmd...
- if ( defined $oldpath ) {
- $ENV{MANPATH} = $manpath;
- }
- else {
- delete $ENV{MANPATH};
- }
} ## end sub runman
#use Carp; # This did break, left for debugging
# This defines the point at which you get the 'deep recursion'
# warning. It MUST be defined or the debugger will not load.
- $deep = 100;
+ $deep = 1000;
# Number of lines around the current one that are shown in the
# 'w' command.
=cut
- if (not $text =~ /::/ and eval { require PadWalker } ) {
+ if (not $text =~ /::/ and eval {
+ local @INC = @INC;
+ pop @INC if $INC[-1] eq '.';
+ require PadWalker } ) {
my $level = 1;
while (1) {
my @info = caller($level);
=cut
push @out, map "$prefix$_", grep /^\Q$text/,
- ( grep /^_?[a-zA-Z]/, keys %$pack ),
+ ( grep /^_?[a-zA-Z]/, do { no strict 'refs'; keys %$pack } ),
( $pack eq '::' ? () : ( grep /::$/, keys %:: ) );
=item *
# The breakpoint was inside an eval. This is a little
# more difficult. XXX and I don't understand it.
- for (@hard) {
+ foreach my $hard_file (@hard) {
# Get over to the eval in question.
- *dbline = $main::{ '_<' . $_ };
- my ( $quoted, $sub, %subs, $line ) = quotemeta $_;
- for $sub ( keys %sub ) {
- next unless $sub{$sub} =~ /^$quoted:(\d+)-(\d+)$/;
- $subs{$sub} = [ $1, $2 ];
+ *dbline = $main::{ '_<' . $hard_file };
+ my $quoted = quotemeta $hard_file;
+ my %subs;
+ for my $sub ( keys %sub ) {
+ if (my ($n1, $n2) = $sub{$sub} =~ /\A$quoted:(\d+)-(\d+)\z/) {
+ $subs{$sub} = [ $n1, $n2 ];
+ }
}
unless (%subs) {
- print $OUT
- "No subroutines in $_, ignoring breakpoints.\n";
+ print {$OUT}
+ "No subroutines in $hard_file, ignoring breakpoints.\n";
next;
}
- LINES: for $line ( keys %dbline ) {
+ LINES: foreach my $line ( keys %dbline ) {
# One breakpoint per sub only:
- my ( $offset, $sub, $found );
- SUBS: for $sub ( keys %subs ) {
+ my ( $offset, $found );
+ SUBS: foreach my $sub ( keys %subs ) {
if (
- $subs{$sub}->[1] >=
- $line # Not after the subroutine
+ $subs{$sub}->[1] >= $line # Not after the subroutine
and (
not defined $offset # Not caught
- or $offset < 0
+ or $offset < 0
)
- )
+ )
{ # or badly caught
$found = $sub;
$offset = $line - $subs{$sub}->[0];
- $offset = "+$offset", last SUBS
- if $offset >= 0;
+ if ($offset >= 0) {
+ $offset = "+$offset";
+ last SUBS;
+ }
} ## end if ($subs{$sub}->[1] >=...
} ## end for $sub (keys %subs)
if ( defined $offset ) {
$postponed{$found} =
- "break $offset if $dbline{$line}";
+ "break $offset if $dbline{$line}";
}
else {
- print $OUT
-"Breakpoint in $_:$line ignored: after all the subroutines.\n";
+ print {$OUT}
+ ("Breakpoint in ${hard_file}:$line ignored:"
+ . " after all the subroutines.\n");
}
} ## end for $line (keys %dbline)
} ## end for (@hard)
# Get the current value of the expression.
# Doesn't handle expressions returning list values!
$evalarg = $1;
- my ($val) = DB::eval();
+ # The &-call is here to ascertain the mutability of @_.
+ my ($val) = &DB::eval;
$val = ( defined $val ) ? "'$val'" : 'undef';
# Save it.
my $which = '';
# Make sure we have some array or another to address later.
- # This means that if ssome reason the tests fail, we won't be
+ # This means that if for some reason the tests fail, we won't be
# trying to stash actions or delete them from the wrong place.
my $aref = [];
https://perl5.git.perl.org / perl5.git / blobdiff