diff options
Diffstat (limited to 'Master/tlpkg/tlperl/lib/perl5db.pl')
-rw-r--r-- | Master/tlpkg/tlperl/lib/perl5db.pl | 209 |
1 files changed, 43 insertions, 166 deletions
diff --git a/Master/tlpkg/tlperl/lib/perl5db.pl b/Master/tlpkg/tlperl/lib/perl5db.pl index bcb4dd5ad20..707d04d6396 100644 --- a/Master/tlpkg/tlperl/lib/perl5db.pl +++ b/Master/tlpkg/tlperl/lib/perl5db.pl @@ -318,7 +318,7 @@ is entered or exited. =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 @@ -523,7 +523,7 @@ BEGIN { # Debugger for Perl 5.00x; perl5db.pl patch level: use vars qw($VERSION $header); -$VERSION = '1.39_10'; +$VERSION = '1.44'; $header = "perl5db.pl version $VERSION"; @@ -1362,7 +1362,8 @@ the R command stuffed into the environment variables. 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 @@ -1822,7 +1823,7 @@ sub _DB__read_next_cmd 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); } @@ -2098,7 +2099,7 @@ sub _DB__handle_forward_slash_command { # 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__}; @@ -2418,6 +2419,9 @@ sub _DB__at_end_of_every_command { 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); @@ -2501,7 +2505,7 @@ my %cmd_lookup = { 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 { @@ -2969,7 +2973,7 @@ Same as for C</>, except the loop runs backwards. =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 @@ -3147,7 +3151,7 @@ again. # # my $obj = DB::Obj->new( # -# The following package declaraton must come before that, +# The following package declaration must come before that, # or else runtime errors will occur with # # PERLDB_OPTS="autotrace nonstop" @@ -4093,9 +4097,6 @@ sub _print_frame_message { } sub DB::sub { - # Do not use a regex in this subroutine -> results in corrupted memory - # See: [perl #66110] - # lock ourselves under threads lock($DBGR); @@ -4268,7 +4269,9 @@ sub lsub : lvalue { $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. @@ -4277,9 +4280,6 @@ sub lsub : lvalue { # 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; } @@ -6091,7 +6091,7 @@ sub cmd_W { } ## 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.*)/) @@ -6146,7 +6146,11 @@ sub print_lineinfo { 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> @@ -6426,7 +6430,7 @@ sub print_trace { # 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. @@ -8898,139 +8902,6 @@ program's STDIN and STDOUT. =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) { @@ -9048,8 +8919,8 @@ sub runman { $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/; @@ -9057,8 +8928,7 @@ sub runman { 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( @@ -9071,20 +8941,27 @@ sub runman { ) { 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 @@ -9165,7 +9042,7 @@ BEGIN { # This does not compile, alas. (XXX eh?) # 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. @@ -9511,7 +9388,7 @@ If the package is C<::> (C<main>), create an empty list; if it's something else, =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 * @@ -10312,7 +10189,7 @@ sub cmd_prepost { 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 = []; |