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
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.40';
+# bump to X.XX in blead, only use X.XX_XX in maint
+$VERSION = '1.55';
$header = "perl5db.pl version $VERSION";
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
}
undef $console;
}
-=item * Unix - use F</dev/tty>.
+=item * Windows or MSDOS - use C<con>.
=cut
- elsif ( -e "/dev/tty" ) {
- $console = "/dev/tty";
+ elsif ( $^O eq 'dos' or -e "con" or $^O eq 'MSWin32' ) {
+ $console = "con";
}
-=item * Windows or MSDOS - use C<con>.
+=item * AmigaOS - use C<CONSOLE:>.
=cut
- elsif ( $^O eq 'dos' or -e "con" or $^O eq 'MSWin32' ) {
- $console = "con";
+ elsif ( $^O eq 'amigaos' ) {
+ $console = "CONSOLE:";
}
=item * VMS - use C<sys$command>.
=cut
- else {
+ elsif ($^O eq 'VMS') {
+ $console = 'sys$command';
+ }
+
+# Keep this penultimate, on the grounds that it satisfies a wide variety of
+# Unix-like systems that would otherwise need to be identified individually.
+
+=item * Unix - use F</dev/tty>.
+
+=cut
- # everything else is ...
- $console = "sys\$command";
+ elsif ( -e "/dev/tty" ) {
+ $console = "/dev/tty";
+ }
+
+# Keep this last.
+
+ else {
+ _db_warn("Can't figure out your console, using stdin");
+ undef $console;
}
=pod
$o = $i unless defined $o;
# read/write on in, or just read, or read on STDIN.
- open( IN, "+<$i" )
- || open( IN, "<$i" )
+ open( IN, '+<', $i )
+ || open( IN, '<', $i )
|| open( IN, "<&STDIN" );
# read/write/create/clobber out, or write/create/clobber out,
# or merge with STDERR, or merge with STDOUT.
- open( OUT, "+>$o" )
- || open( OUT, ">$o" )
+ open( OUT, '+>', $o )
+ || open( OUT, '>', $o )
|| open( OUT, ">&STDERR" )
|| open( OUT, ">&STDOUT" ); # so we don't dongle stdout
$cmd =~ s/\A\s+//s; # trim annoying leading whitespace
$cmd =~ s/\s+\z//s; # trim annoying trailing whitespace
- my ($verb, $args) = $cmd =~ m{\A(\S*)\s*(.*)}s;
+ # A single-character debugger command can be immediately followed by its
+ # argument if they aren't both alphanumeric; otherwise require space
+ # between commands and arguments:
+ my ($verb, $args) = $cmd =~ m{\A(.\b|\S*)\s*(.*)}s;
$obj->cmd_verb($verb);
$obj->cmd_args($args);
= $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 = $@) {
# 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
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);
# '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, },
(map { $_ => {t => 'm', v => '_handle_cmd_wrapper_commands' }, }
qw(a A b B e E h i l L M o O v w W)),
);
+};
sub DB {
=head4 C<-> - back one window
We change C<$start> to be one window back; if we go back past the first line,
-we set it to be the first line. We ser C<$incr> to put us back at the
+we set it to be the first line. We set C<$incr> to put us back at the
currently-executing line, and then put a C<l $start +> (list one window from
C<$start>) in C<$cmd> to be executed later.
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')
}
sub DB::sub {
- # Do not use a regex in this subroutine -> results in corrupted memory
- # See: [perl #66110]
-
- # 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 the last ten characters are '::AUTOLOAD', note we've traced
- # into AUTOLOAD for $sub.
- if ( length($sub) > 10 && substr( $sub, -10, 10 ) eq '::AUTOLOAD' ) {
- no strict 'refs';
- $al = " for $$sub" if defined $$sub;
- }
# We stack the stack pointer and then increment it to protect us
# from a situation that might unwind a whole bunch of call frames
# unwind the same amount when multiple stack frames are unwound.
local $stack_depth = $stack_depth + 1; # Protect from non-local exits
- # Expand @stack.
- $#stack = $stack_depth;
+ {
+ # lock ourselves under threads
+ # While lock() permits recursive locks, there's two cases where it's bad
+ # that we keep a hold on the lock while we call the sub:
+ # - during cloning, Package::CLONE might be called in the context of the new
+ # thread, which will deadlock if we hold the lock across the threads::new call
+ # - for any function that waits any significant time
+ # This also deadlocks if the parent thread joins(), since holding the lock
+ # will prevent any child threads passing this point.
+ # So release the lock for the function call.
+ lock($DBGR);
- # Save current single-step setting.
- $stack[-1] = $single;
+ # 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).
+ if ($sub eq 'threads::new' && $ENV{PERL5DB_THREADED}) {
+ print "creating new thread\n";
+ }
- # Turn off all flags except single-stepping.
- $single &= 1;
+ # If the last ten characters are '::AUTOLOAD', note we've traced
+ # into AUTOLOAD for $sub.
+ if ( length($sub) > 10 && substr( $sub, -10, 10 ) eq '::AUTOLOAD' ) {
+ no strict 'refs';
+ $al = " for $$sub" if defined $$sub;
+ }
- # If we've gotten really deeply recursed, turn on the flag that will
- # make us stop with the 'deep recursion' message.
- $single |= 4 if $stack_depth == $deep;
+ # Expand @stack.
+ $#stack = $stack_depth;
- # If frame messages are on ...
+ # Save current single-step setting.
+ $stack[-1] = $single;
- _print_frame_message($al);
- # standard frame entry message
+ # Turn off all flags except single-stepping.
+ $single &= 1;
- my $print_exit_msg = sub {
- # Check for exit trace messages...
- if ($frame & 2)
- {
- if ($frame & 4) # Extended exit message
- {
- _indent_print_line_info(0, "out ");
- print_trace( $LINEINFO, 0, 1, 1, "$sub$al" );
- }
- else
- {
- _indent_print_line_info(0, "exited $sub$al\n" );
- }
- }
- return;
- };
+ # If we've gotten really deeply recursed, turn on the flag that will
+ # make us stop with the 'deep recursion' message.
+ $single |= 4 if $stack_depth == $deep;
+
+ # If frame messages are on ...
+
+ _print_frame_message($al);
+ }
# Determine the sub's return type, and capture appropriately.
if (wantarray) {
# Called in array context. call sub and capture output.
# DB::DB will recursively get control again if appropriate; we'll come
# back here when the sub is finished.
- {
- no strict 'refs';
- @ret = &$sub;
- }
+ no strict 'refs';
+ @ret = &$sub;
+ }
+ elsif ( 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;
+ }
+
+ {
+ lock($DBGR);
# Pop the single-step value back off the stack.
$single |= $stack[ $stack_depth-- ];
- $print_exit_msg->();
+ if ($frame & 2) {
+ if ($frame & 4) { # Extended exit message
+ _indent_print_line_info(0, "out ");
+ print_trace( $LINEINFO, -1, 1, 1, "$sub$al" );
+ }
+ else {
+ _indent_print_line_info(0, "exited $sub$al\n" );
+ }
+ }
- # Print the return info if we need to.
- if ( $doret eq $stack_depth or $frame & 16 ) {
+ if (wantarray) {
+ # Print the return info if we need to.
+ if ( $doret eq $stack_depth or $frame & 16 ) {
- # Turn off output record separator.
- local $\ = '';
- my $fh = ( $doret eq $stack_depth ? $OUT : $LINEINFO );
+ # Turn off output record separator.
+ local $\ = '';
+ my $fh = ( $doret eq $stack_depth ? $OUT : $LINEINFO );
- # Indent if we're printing because of $frame tracing.
- if ($frame & 16)
- {
- print {$fh} ' ' x $stack_depth;
- }
+ # Indent if we're printing because of $frame tracing.
+ if ($frame & 16)
+ {
+ print {$fh} ' ' x $stack_depth;
+ }
- # Print the return value.
- print {$fh} "list context return from $sub:\n";
- dumpit( $fh, \@ret );
+ # Print the return value.
+ print {$fh} "list context return from $sub:\n";
+ dumpit( $fh, \@ret );
- # And don't print it again.
- $doret = -2;
- } ## end if ($doret eq $stack_depth...
+ # And don't print it again.
+ $doret = -2;
+ } ## end if ($doret eq $stack_depth...
# And we have to return the return value now.
- @ret;
- } ## end if (wantarray)
-
- # Scalar context.
- else {
- if ( defined wantarray ) {
- no strict 'refs';
- # Save the value if it's wanted at all.
- $ret = &$sub;
- }
+ @ret;
+ } ## end if (wantarray)
+ # Scalar context.
else {
- no strict 'refs';
- # Void return, explicitly.
- &$sub;
- undef $ret;
- }
-
- # Pop the single-step value off the stack.
- $single |= $stack[ $stack_depth-- ];
-
- # If we're doing exit messages...
- $print_exit_msg->();
-
- # If we are supposed to show the return value... same as before.
- if ( $doret eq $stack_depth or $frame & 16 and defined wantarray ) {
- local $\ = '';
- my $fh = ( $doret eq $stack_depth ? $OUT : $LINEINFO );
- print $fh ( ' ' x $stack_depth ) if $frame & 16;
- print $fh (
- defined wantarray
- ? "scalar context return from $sub: "
- : "void context return from $sub\n"
- );
- dumpit( $fh, $ret ) if defined wantarray;
- $doret = -2;
- } ## end if ($doret eq $stack_depth...
-
- # Return the appropriate scalar value.
- $ret;
- } ## end else [ if (wantarray)
+ # If we are supposed to show the return value... same as before.
+ if ( $doret eq $stack_depth or $frame & 16 and defined wantarray ) {
+ local $\ = '';
+ my $fh = ( $doret eq $stack_depth ? $OUT : $LINEINFO );
+ print $fh ( ' ' x $stack_depth ) if $frame & 16;
+ print $fh (
+ defined wantarray
+ ? "scalar context return from $sub: "
+ : "void context return from $sub\n"
+ );
+ dumpit( $fh, $ret ) if defined wantarray;
+ $doret = -2;
+ } ## end if ($doret eq $stack_depth...
+
+ # Return the appropriate scalar value.
+ $ret;
+ } ## end else [ if (wantarray)
+ }
} ## end sub _sub
sub lsub : lvalue {
- no strict 'refs';
-
- # 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 the last ten characters are C'::AUTOLOAD', note we've traced
- # into AUTOLOAD for $sub.
- if ( length($sub) > 10 && substr( $sub, -10, 10 ) eq '::AUTOLOAD' ) {
- $al = " for $$sub";
- }
-
# We stack the stack pointer and then increment it to protect us
# from a situation that might unwind a whole bunch of call frames
# at once. Localizing the stack pointer means that it will automatically
$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.
- $single |= 4 if $stack_depth == $deep;
+ no strict 'refs';
+ {
+ # lock ourselves under threads
+ lock($DBGR);
- # If frame messages are on ...
- _print_frame_message($al);
+ # 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";
+ }
- # Pop the single-step value back off the stack.
- $single |= $stack[ $stack_depth-- ];
+ # If the last ten characters are C'::AUTOLOAD', note we've traced
+ # into AUTOLOAD for $sub.
+ if ( length($sub) > 10 && substr( $sub, -10, 10 ) eq '::AUTOLOAD' ) {
+ $al = " for $$sub";
+ }
+
+ # If we've gotten really deeply recursed, turn on the flag that will
+ # make us stop with the 'deep recursion' message.
+ $single |= 4 if $stack_depth == $deep;
+
+ # If frame messages are on ...
+ _print_frame_message($al);
+ }
# call the original lvalue sub.
&$sub;
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>
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;
+ # Turn high-bit characters into meta-whatever, and controls into like
+ # '^D'.
+ require 'meta_notation.pm';
+ $_ = _meta_notation($_) if /[[:^print:]]/a;
return $_;
}
$i++
)
{
-
- # Go through the arguments and save them for later.
- my $save_args = _dump_trace_calc_save_args($nothard);
+ # if the sub has args ($h true), make an anonymous array of the
+ # dumped args.
+ my $args = $h ? _dump_trace_calc_save_args($nothard) : undef;
# If context is true, this is array (@)context.
# If context is false, this is scalar ($) context.
# happen' trap.)
$context = $context ? '@' : ( defined $context ? "\$" : '.' );
- # if the sub has args ($h true), make an anonymous array of the
- # dumped args.
- $args = $h ? $save_args : undef;
-
# remove trailing newline-whitespace-semicolon-end of line sequence
# from the eval text, if any.
$e =~ s/\n\s*\;\s*\Z// if $e;
# 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" : "" ),
if ($tty) {
my ( $i, $o ) = split $tty, /,/;
$o = $i unless defined $o;
- open( IN, "<$i" ) or die "Cannot open TTY '$i' for read: $!";
- open( OUT, ">$o" ) or die "Cannot open TTY '$o' for write: $!";
+ open( IN, '<', $i ) or die "Cannot open TTY '$i' for read: $!";
+ open( OUT, '>', $o ) or die "Cannot open TTY '$o' for write: $!";
$IN = \*IN;
$OUT = \*OUT;
_autoflush($OUT);
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
}
# Open file onto the debugger's filehandles, if you can.
- open IN, $in or die "cannot open '$in' for read: $!";
- open OUT, ">$out" or die "cannot open '$out' for write: $!";
+ open IN, '<', $in or die "cannot open '$in' for read: $!";
+ open OUT, '>', $out or die "cannot open '$out' for write: $!";
# Swap to the new filehandles.
reset_IN_OUT( \*IN, \*OUT );
# 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
- 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 *
https://perl5.git.perl.org / perl5.git / blobdiff