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_10';
+$VERSION = '1.46';
$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) {
{
*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
# 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);
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);
{ 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.
# 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.
$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)
}
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(
', ',
# 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.
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>
# 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,
=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
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 *
# 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.
https://perl5.git.perl.org / perl5.git / blobdiff