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.41';
+$VERSION = '1.49_02';
$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
}
$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
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 {
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')
$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;
}
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 $_;
}
# 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" : "" ),
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
# 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
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