X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/47e3b8cc5cc82dbc1d3f061ed08fb657475a5832..2384afee950038d95f6f7b226c7832d7264c9a92:/lib/perl5db.pl diff --git a/lib/perl5db.pl b/lib/perl5db.pl index c9844fd..0488a50 100644 --- a/lib/perl5db.pl +++ b/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 return from I: I> messages on subroutine/eval exit. Ignored if C<4> is is not on. +=item * 16 - Adds C return from I: I> messages on subroutine/eval exit. Ignored if C<4> is not on. =back @@ -512,18 +512,23 @@ package DB; 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_05'; +$VERSION = '1.46'; $header = "perl5db.pl version $VERSION"; @@ -744,7 +749,7 @@ sub eval { # 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) { @@ -1331,6 +1336,9 @@ if (not defined &get_fork_TTY) # only if no routine exists { *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 } @@ -1362,7 +1370,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 @@ -1472,6 +1481,15 @@ use vars qw($lineinfo $doccmd); 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); @@ -1513,7 +1531,7 @@ We then determine what the console should be on various systems: undef $console; } -=item * Unix - use C. +=item * Unix - use F. =cut @@ -1545,7 +1563,7 @@ We then determine what the console should be on various systems: Several other systems don't use a specific console. We C for those (Windows using a slave editor/graphical debugger, NetWare, OS/2 -with a slave editor, Epoc). +with a slave editor). =cut @@ -1568,11 +1586,6 @@ with a slave editor, Epoc). $console = undef; } - # EPOC also falls into the 'got to use STDIN' camp. - if ( $^O eq 'epoc' ) { - $console = undef; - } - =pod If there is a TTY hanging around from a parent, we use that as the console. @@ -1660,7 +1673,7 @@ and if we can. } ## 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 @@ -1789,7 +1802,8 @@ sub _DB__determine_if_we_should_break # 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); @@ -1817,7 +1831,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); } @@ -1834,17 +1848,23 @@ sub _DB__read_next_cmd } sub _DB__trim_command_and_return_first_component { + my ($obj) = @_; + $cmd =~ s/\A\s+//s; # trim annoying leading whitespace $cmd =~ s/\s+\z//s; # trim annoying trailing whitespace - $cmd =~ m{\A(\S*)}; - return $1; + my ($verb, $args) = $cmd =~ m{\A(\S*)\s*(.*)}s; + + $obj->cmd_verb($verb); + $obj->cmd_args($args); + + return; } sub _DB__handle_f_command { - if (($file) = $cmd =~ /\Af\b\s*(.*)/) { - $file =~ s/\s+$//; + my ($obj) = @_; + if ($file = $obj->cmd_args) { # help for no arguments (old-style was return from sub). if ( !$file ) { print $OUT @@ -1893,7 +1913,7 @@ sub _DB__handle_dot_command { my ($obj) = @_; # . command. - if ($cmd eq '.') { + if ($obj->_is_full('.')) { $incr = -1; # stay at current line # Reset everything to the old location. @@ -1914,12 +1934,12 @@ sub _DB__handle_y_command { my ($obj) = @_; if (my ($match_level, $match_vars) - = $cmd =~ /^y(?:\s+(\d*)\s*(.*))?$/) { + = $obj->cmd_args =~ /\A(?:(\d*)\s*(.*))?\z/) { # See if we've got the necessary support. if (!eval { require PadWalker; PadWalker->VERSION(0.08) }) { my $Err = $@; - DB::warn( + _db_warn( $Err =~ /locate/ ? "PadWalker module not found - please install\n" : $Err @@ -1937,12 +1957,12 @@ sub _DB__handle_y_command { 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 = $@) { $Err =~ s/ at .*//; - DB::warn($Err); + _db_warn($Err); next CMD; } @@ -1963,16 +1983,16 @@ sub _DB__handle_y_command { sub _DB__handle_c_command { my ($obj) = @_; - if (my ($new_i) = $cmd =~ m#\Ac\b\s*([\w:]*)\s*\z#) { + my $i = $obj->cmd_args; - $obj->i_cmd($new_i); + if ($i =~ m#\A[\w:]*\z#) { # Hey, show's over. The debugged program finished # executing already. next CMD if _DB__is_finished(); # Capture the place to put a one-time break. - $subname = $obj->i_cmd; + $subname = $i; # Probably not needed, since we finish an interactive # sub-session anyway... @@ -1995,13 +2015,13 @@ sub _DB__handle_c_command { # to where the subroutine is defined; we call find_sub, # break up the return value, and assign it in one # operation. - ( $file, $new_i ) = ( find_sub($subname) =~ /^(.*):(.*)$/ ); + ( $file, $i ) = ( find_sub($subname) =~ /^(.*):(.*)$/ ); # Force the line number to be numeric. - $obj->i_cmd($new_i + 0); + $i = $i + 0; # If we got a line number, we found the sub. - if ($obj->i_cmd) { + if ($i) { # Switch all the debugger's internals around so # we're actually working with that file. @@ -2014,9 +2034,12 @@ sub _DB__handle_c_command { # Scan forward to the first executable line # after the 'sub whatever' line. $max = $#dbline; - my $ii = $obj->i_cmd; - ++$ii while $dbline[$ii] == 0 && $ii < $max; - $obj->i_cmd($ii); + my $_line_num = $i; + while ($dbline[$_line_num] == 0 && $_line_num< $max) + { + $_line_num++; + } + $i = $_line_num; } ## end if ($i) # We didn't find a sub by that name. @@ -2047,22 +2070,22 @@ sub _DB__handle_c_command { # On the gripping hand, we can't do anything unless the # current value of $i points to a valid breakable line. # Check that. - if ($obj->i_cmd) { + if ($i) { # Breakable? - if ( $dbline[$obj->i_cmd] == 0 ) { - print $OUT "Line " . $obj->i_cmd . " not breakable.\n"; + if ( $dbline[$i] == 0 ) { + print $OUT "Line $i not breakable.\n"; next CMD; } # Yes. Set up the one-time-break sigil. - $dbline{$obj->i_cmd} =~ s/($|\0)/;9$1/; # add one-time-only b.p. - _enable_breakpoint_temp_enabled_status($filename, $obj->i_cmd); + $dbline{$i} =~ s/($|\0)/;9$1/; # add one-time-only b.p. + _enable_breakpoint_temp_enabled_status($filename, $i); } ## end if ($i) # Turn off stack tracing from here up. - for my $i (0 .. $stack_depth) { - $stack[ $i ] &= ~1; + for my $j (0 .. $stack_depth) { + $stack[ $j ] &= ~1; } last CMD; } @@ -2084,7 +2107,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__}; @@ -2095,7 +2118,7 @@ sub _DB__handle_forward_slash_command { # Oops. Bad pattern. No biscuit. # Print the eval error and go back for more # commands. - print $OUT "$@"; + print {$OUT} "$@"; next CMD; } $obj->pat($inpat); @@ -2119,7 +2142,9 @@ sub _DB__handle_forward_slash_command { ++$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); @@ -2131,11 +2156,11 @@ sub _DB__handle_forward_slash_command { 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; @@ -2235,10 +2260,18 @@ sub _DB__handle_question_mark_command { sub _DB__handle_restart_and_rerun_commands { my ($obj) = @_; + my $cmd_cmd = $obj->cmd_verb; + my $cmd_params = $obj->cmd_args; # R - restart execution. # rerun - controlled restart execution. - if (my ($cmd_cmd, $cmd_params) = - $cmd =~ /\A((?:R)|(?:rerun\s*(.*)))\z/) { + 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 @@ -2277,14 +2310,14 @@ sub _DB__handle_run_command_in_pager_command { # Default pager is into a pipe. Redirect I/O. open( SAVEOUT, ">&STDOUT" ) - || DB::warn("Can't save STDOUT"); + || _db_warn("Can't save STDOUT"); open( STDOUT, ">&OUT" ) - || DB::warn("Can't redirect STDOUT"); + || _db_warn("Can't redirect STDOUT"); } ## end if ($pager =~ /^\|/) else { # Not into a pipe. STDOUT is safe. - open( SAVEOUT, ">&OUT" ) || &warn("Can't save DB::OUT"); + open( SAVEOUT, ">&OUT" ) || _db_warn("Can't save DB::OUT"); } # Fix up environment to record we have less if so. @@ -2293,21 +2326,21 @@ sub _DB__handle_run_command_in_pager_command { unless ( $obj->piped(scalar ( open( OUT, $pager ) ) ) ) { # Couldn't open pipe to pager. - DB::warn("Can't pipe output to '$pager'"); + _db_warn("Can't pipe output to '$pager'"); if ( $pager =~ /^\|/ ) { # Redirect I/O back again. open( OUT, ">&STDOUT" ) # XXX: lost message - || DB::warn("Can't restore DB::OUT"); + || _db_warn("Can't restore DB::OUT"); open( STDOUT, ">&SAVEOUT" ) - || DB::warn("Can't restore STDOUT"); + || _db_warn("Can't restore STDOUT"); close(SAVEOUT); } ## end if ($pager =~ /^\|/) else { # Redirect I/O. STDOUT already safe. open( OUT, ">&STDOUT" ) # XXX: lost message - || DB::warn("Can't restore DB::OUT"); + || _db_warn("Can't restore DB::OUT"); } next CMD; } ## end unless ($piped = open(OUT,... @@ -2317,7 +2350,7 @@ sub _DB__handle_run_command_in_pager_command { 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. @@ -2385,9 +2418,9 @@ sub _DB__at_end_of_every_command { # Reopen filehandle for our output (if we can) and # restore STDOUT (if we can). - open( OUT, ">&STDOUT" ) || &warn("Can't restore DB::OUT"); + open( OUT, ">&STDOUT" ) || _db_warn("Can't restore DB::OUT"); open( STDOUT, ">&SAVEOUT" ) - || &warn("Can't restore STDOUT"); + || _db_warn("Can't restore STDOUT"); # Turn off pipe exception handler if necessary. $SIG{PIPE} = "DEFAULT" if $SIG{PIPE} eq \&DB::catch; @@ -2398,9 +2431,12 @@ sub _DB__at_end_of_every_command { else { # Non-piped "pager". Just restore STDOUT. - open( OUT, ">&SAVEOUT" ) || &warn("Can't restore DB::OUT"); + 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); @@ -2417,13 +2453,74 @@ sub _DB__at_end_of_every_command { 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} < { t => 'm', v => '_handle_q_command' }, + '-' => { t => 'm', v => '_handle_dash_command', }, + '.' => { t => 's', v => \&_DB__handle_dot_command, }, + '=' => { t => 'm', v => '_handle_equal_sign_command', }, + 'H' => { t => 'm', v => '_handle_H_command', }, + 'S' => { t => 'm', v => '_handle_S_command', }, + 'T' => { t => 'm', v => '_handle_T_command', }, + 'W' => { t => 'm', v => '_handle_W_command', }, + 'c' => { t => 's', v => \&_DB__handle_c_command, }, + 'f' => { t => 's', v => \&_DB__handle_f_command, }, + 'm' => { t => 's', v => \&_DB__handle_m_command, }, + 'n' => { t => 'm', v => '_handle_n_command', }, + 'p' => { t => 'm', v => '_handle_p_command', }, + 'q' => { t => 'm', v => '_handle_q_command', }, + 'r' => { t => 'm', v => '_handle_r_command', }, + 's' => { t => 'm', v => '_handle_s_command', }, + 'save' => { t => 'm', v => '_handle_save_command', }, + 'source' => { t => 'm', v => '_handle_source_command', }, + 't' => { t => 'm', v => '_handle_t_command', }, + 'w' => { t => 'm', v => '_handle_w_command', }, + 'x' => { t => 'm', v => '_handle_x_command', }, + 'y' => { t => 's', v => \&_DB__handle_y_command, }, + (map { $_ => { t => 'm', v => '_handle_V_command_and_X_command', }, } + ('X', 'V')), + (map { $_ => { t => 'm', v => '_handle_enable_disable_commands', }, } + qw(enable disable)), + (map { $_ => + { 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 v w W)), ); sub DB { @@ -2442,7 +2539,8 @@ sub DB { $tid = eval { "[".threads->tid."]" }; } - my $i; + my $cmd_verb; + my $cmd_args; my $obj = DB::Obj->new( { @@ -2451,7 +2549,8 @@ sub DB { after => \$after, explicit_stop => \$explicit_stop, infix => \$infix, - i_cmd => \$i, + cmd_args => \$cmd_args, + cmd_verb => \$cmd_verb, pat => \$pat, piped => \$piped, selected => \$selected, @@ -2462,7 +2561,7 @@ sub DB { # Preserve current values of $@, $!, $^E, $,, $/, $\, $^W. # The code being debugged may have altered them. - &save; + DB::save(); # Since DB::DB gets called after every line, we can use caller() to # figure out where we last were executing. Sneaky, eh? This works because @@ -2483,14 +2582,15 @@ 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 @@ -2576,7 +2676,8 @@ If there are any preprompt actions, execute those as well. # 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 @@ -2588,7 +2689,8 @@ If there are any preprompt actions, execute those as well. # 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. @@ -2700,7 +2802,7 @@ it up. # via direct user input. It allows us to 'redo PIPE' to # re-execute command processing without reading a new command. PIPE: { - $i = _DB__trim_command_and_return_first_component(); + _DB__trim_command_and_return_first_component($obj); =head3 COMMAND ALIASES @@ -2712,7 +2814,7 @@ completely replacing it. =cut # See if there's an alias for the command, and set it up if so. - if ( $alias{$i} ) { + if ( $alias{$cmd_verb} ) { # Squelch signal handling; we want to keep control here # if something goes loco during the alias eval. @@ -2723,14 +2825,14 @@ completely replacing it. # scope! Otherwise, we can't see the special debugger # variables, or get to the debugger's subs. (Well, we # _could_, but why make it even more complicated?) - eval "\$cmd =~ $alias{$i}"; + eval "\$cmd =~ $alias{$cmd_verb}"; if ($@) { local $\ = ''; - print $OUT "Couldn't evaluate '$i' alias: $@"; + print $OUT "Couldn't evaluate '$cmd_verb' alias: $@"; next CMD; } - $i = _DB__trim_command_and_return_first_component(); - } ## end if ($alias{$i}) + _DB__trim_command_and_return_first_component($obj); + } ## end if ($alias{$cmd_verb}) =head3 MAIN-LINE COMMANDS @@ -2745,7 +2847,12 @@ environment, and executing with the last value of C<$?>. =cut - if (my $cmd_rec = $cmd_lookup{$i}) { + # All of these commands were remapped in perl 5.8.0; + # we send them off to the secondary dispatcher (see below). + $obj->_handle_special_char_cmd_wrapper_commands; + _DB__trim_command_and_return_first_component($obj); + + if (my $cmd_rec = $cmd_lookup{$cmd_verb}) { my $type = $cmd_rec->{t}; my $val = $cmd_rec->{v}; if ($type eq 'm') { @@ -2761,18 +2868,10 @@ environment, and executing with the last value of C<$?>. Turn tracing on or off. Inverts the appropriate bit in C<$trace> (q.v.). If level is specified, set C<$trace_to_depth>. -=cut - - $obj->_handle_t_command; - =head4 C - list subroutines matching/not matching a pattern Walks through C<%sub>, checking to see whether or not to print the name. -=cut - - $obj->_handle_S_command; - =head4 C - list variables in current package Since the C command actually processes this, just change this to the @@ -2782,42 +2881,24 @@ appropriate C command and fall through. Uses C to dump out the current values for selected variables. -=cut - - $obj->_handle_V_command_and_X_command; - =head4 C - evaluate and print an expression Hands the expression off to C, setting it up to print the value via C instead of just printing it directly. -=cut - - $obj->_handle_x_command; - =head4 C - print methods Just uses C to determine what methods are available. -=cut - - _DB__handle_m_command($obj); - =head4 C - switch files -=cut - - _DB__handle_f_command($obj); +Switch to a different filename. =head4 C<.> - return to last-executed line. We set C<$incr> to -1 to indicate that the debugger shouldn't move ahead, and then we look up the line in the magical C<%dbline> hash. -=cut - - _DB__handle_dot_command($obj); - =head4 C<-> - back one window We change C<$start> to be one window back; if we go back past the first line, @@ -2825,11 +2906,6 @@ we set it to be the first line. We ser C<$incr> to put us back at the currently-executing line, and then put a C (list one window from C<$start>) in C<$cmd> to be executed later. -=cut - - # - - back a window. - $obj->_handle_dash_command; - =head3 PRE-580 COMMANDS VS. NEW COMMANDS: C, EE, E<0x7B>, E<0x7B>E<0x7B>> In Perl 5.8.0, a realignment of the commands was done to fix up a number of @@ -2839,21 +2915,11 @@ retain the old commands for those who were used to using them or who preferred them. At this point, we check for the new commands and call C to deal with them instead of processing them in-line. -=cut - - # All of these commands were remapped in perl 5.8.0; - # we send them off to the secondary dispatcher (see below). - $obj->_handle_cmd_wrapper_commands; - =head4 C - List lexicals in higher scope Uses C to find the lexicals supplied as arguments in a scope above the current one and then displays then using C. -=cut - - _DB__handle_y_command($obj); - =head3 COMMANDS NOT WORKING AFTER PROGRAM ENDS All of the commands below this point don't work after the program being @@ -2868,20 +2934,11 @@ Done by setting C<$single> to 2, which forces subs to execute straight through when entered (see C). We also save the C command in C<$laststep>, so a null command knows what to re-execute. -=cut - - # n - next - $obj->_handle_n_command; - =head4 C - single-step, entering subs Sets C<$single> to 1, which causes C to continue tracing inside subs. Also saves C as C<$lastcmd>. -=cut - - $obj->_handle_s_command; - =head4 C - run continuously, setting an optional breakpoint Most of the code for this command is taken up with locating the optional @@ -2889,11 +2946,6 @@ breakpoint, which is either a subroutine name or a line number. We set the appropriate one-time-break in C<@dbline> and then turn off single-stepping in this and all call levels above this one. -=cut - - # c - start continuous execution. - _DB__handle_c_command($obj); - =head4 C - return from a subroutine For C to work properly, the debugger has to stop execution again @@ -2902,35 +2954,18 @@ single-stepping to be on in the call level above the current one. If we are printing return values when a C is executed, set C<$doret> appropriately, and force us out of the command loop. -=cut - - # r - return from the current subroutine. - $obj->_handle_r_command; - =head4 C - stack trace Just calls C. -=cut - - $obj->_handle_T_command; - =head4 C - List window around current line. Just calls C. -=cut - - $obj->_handle_w_command; - =head4 C - watch-expression processing. Just calls C. -=cut - - $obj->_handle_W_command; - =head4 C - search forward for a string in the source We take the argument and treat it as a pattern. If it turns out to be a @@ -2953,7 +2988,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 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 @@ -2963,7 +2998,7 @@ into C<$cmd>, and redoes the loop to execute it. =head4 C<$sh$sh> - C command -Calls the C to handle the command. This keeps the C and +Calls the C<_db_system()> to handle the command. This keeps the C and C from getting messed up. =cut @@ -2981,23 +3016,19 @@ If a command is found, it is placed in C<$cmd> and executed via C. =head4 C<$sh> - Invoke a shell -Uses C to invoke a shell. +Uses C<_db_system()> to invoke a shell. =cut =head4 C<$sh I> - Force execution of a command in a shell Like the above, but the command is passed to the shell. Again, we use -C to avoid problems with C and C. +C<_db_system()> to avoid problems with C and C. =head4 C - display commands in history Prints the contents of C<@hist> (if any). -=cut - - $obj->_handle_H_command; - =head4 C - look up documentation Just calls C to print the appropriate document. @@ -3011,36 +3042,19 @@ Just calls C to print the appropriate document. Builds a C expression in the C<$cmd>; this will get executed at the bottom of the loop. -=cut - - $obj->_handle_p_command; - =head4 C<=> - define command alias Manipulates C<%alias> to add or list command aliases. -=cut - - # = - set up a command alias. - $obj->_handle_equal_sign_command; - =head4 C - read commands from a file. Opens a lexical filehandle and stacks it on C<@cmdfhs>; C will pick it up. -=cut - - $obj->_handle_source_command; - =head4 C C - enable or disable breakpoints This enables or disables breakpoints. -=cut - - $obj->_handle_enable_disable_commands; - =head4 C - send current history to a file Takes the complete history, (not the shrunken version you see with C), @@ -3048,11 +3062,6 @@ and saves it to the given filename, so it can be replayed using C. Note that all C<^(save|source)>'s are commented out with a view to minimise recursion. -=cut - - # save source - write commands to a file for later use - $obj->_handle_save_command; - =head4 C - restart Restart the debugger session. @@ -3061,12 +3070,6 @@ Restart the debugger session. Return to any given position in the B-history list -=cut - - # R - restart execution. - # rerun - controlled restart execution. - _DB__handle_restart_and_rerun_commands($obj); - =head4 C<|, ||> - pipe output through the pager. For C<|>, we save C (the debugger's output filehandle) and C @@ -3094,12 +3097,16 @@ any variables we might want to address in the C package. } # 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) { @@ -3145,7 +3152,8 @@ again. # Evaluate post-prompt commands. foreach $evalarg (@$post) { - DB::eval(); + # The &-call is here to ascertain the mutability of @_. + &DB::eval; } } # if ($single || $signal) @@ -3154,6 +3162,18 @@ again. (); } ## 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 { @@ -3177,7 +3197,8 @@ sub _init { { no strict 'refs'; foreach my $slot_name (qw( - after explicit_stop infix pat piped position prefix selected i_cmd + after explicit_stop infix pat piped position prefix selected cmd_verb + cmd_args )) { my $slot = $slot_name; *{$slot} = sub { @@ -3239,38 +3260,6 @@ sub _DB_on_init__initialize_globals 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} <cmd_args(); + + if ((!length($levels)) or ($levels !~ /\D/)) { $trace ^= 1; local $\ = ''; $DB::trace_to_depth = $levels ? $stack_depth + $levels : 1E9; @@ -3411,8 +3410,10 @@ sub _handle_t_command { sub _handle_S_command { + my $self = shift; + if (my ($print_all_subs, $should_reverse, $Spatt) - = $DB::cmd =~ /\AS(\s+(!)?(.+))?\z/) { + = $self->cmd_args =~ /\A((!)?(.+))?\z/) { # $Spatt is the pattern (if any) to use. # Reverse scan? my $Srev = defined $should_reverse; @@ -3439,12 +3440,13 @@ sub _handle_S_command { } sub _handle_V_command_and_X_command { + my $self = shift; $DB::cmd =~ s/^X\b/V $DB::package/; # Bare V commands get the currently-being-debugged package # added. - if ($DB::cmd eq "V") { + if ($self->_is_full('V')) { $DB::cmd = "V $DB::package"; } @@ -3473,7 +3475,7 @@ sub _handle_V_command_and_X_command { # must detect sigpipe failures - not catching # then will cause the debugger to die. eval { - &main::dumpvar( + main::dumpvar( $packname, defined $option{dumpDepth} ? $option{dumpDepth} @@ -3503,8 +3505,9 @@ sub _handle_V_command_and_X_command { } sub _handle_dash_command { + my $self = shift; - if ($DB::cmd eq '-') { + if ($self->_is_full('-')) { # back up by a window; go to 1 if back too far. $start -= $incr + $window + 1; @@ -3513,6 +3516,7 @@ sub _handle_dash_command { # Generate and execute a "l +" command (handled below). $DB::cmd = 'l ' . ($start) . '+'; + redo CMD; } return; } @@ -3533,10 +3537,10 @@ sub _n_or_s_commands_generic { sub _n_or_s { my ($self, $letter, $new_val) = @_; - if ($DB::cmd eq $letter) { + if ($self->_is_full($letter)) { $self->_n_or_s_commands_generic($new_val); } - elsif ($DB::cmd =~ m#\A\Q$letter\E\b#) { + else { $self->_n_or_s_and_arg_commands_generic($letter, $new_val); } @@ -3557,8 +3561,9 @@ sub _handle_s_command { sub _handle_r_command { my $self = shift; + # r - return from the current subroutine. - if ($DB::cmd eq 'r') { + if ($self->_is_full('r')) { # Can't do anything if the program's over. next CMD if DB::_DB__is_finished(); @@ -3575,7 +3580,9 @@ sub _handle_r_command { } sub _handle_T_command { - if ($DB::cmd eq 'T') { + my $self = shift; + + if ($self->_is_full('T')) { DB::print_trace( $OUT, 1 ); # skip DB next CMD; } @@ -3584,16 +3591,18 @@ sub _handle_T_command { } sub _handle_w_command { - if (my ($arg) = $DB::cmd =~ /\Aw\b\s*(.*)/s) { - DB::cmd_w( 'w', $arg ); - next CMD; - } + my $self = shift; + + DB::cmd_w( 'w', $self->cmd_args() ); + next CMD; return; } sub _handle_W_command { - if (my ($arg) = $DB::cmd =~ /\AW\b\s*(.*)/s) { + my $self = shift; + + if (my $arg = $self->cmd_args) { DB::cmd_W( 'W', $arg ); next CMD; } @@ -3614,12 +3623,13 @@ sub _handle_rc_recall_command { # Y - index back from most recent (by 1 if bare minus) # N - go to that particular command slot or the last # thing if nothing following. - my $new_i = $minus ? ( $#hist - ( $arg || 1 ) ) : ( $arg || $#hist ); - $self->i_cmd($new_i); + $self->cmd_verb( + scalar($minus ? ( $#hist - ( $arg || 1 ) ) : ( $arg || $#hist )) + ); # Pick out the command desired. - $DB::cmd = $hist[$self->i_cmd]; + $DB::cmd = $hist[$self->cmd_verb]; # Print the command to be executed and restart the loop # with that command in the buffer. @@ -3643,7 +3653,7 @@ sub _handle_rc_search_history_command { # Toss off last entry if length is >1 (and it always is). pop(@hist) if length($DB::cmd) > 1; - my $i = $self->i_cmd; + my $i; # Look backward through the history. SEARCH_HIST: @@ -3652,9 +3662,7 @@ sub _handle_rc_search_history_command { last SEARCH_HIST if $hist[$i] =~ /$pat/; } - $self->i_cmd($i); - - if ( !$self->i_cmd ) { + if ( !$i ) { # Never found it. print $OUT "No such command!\n\n"; @@ -3662,7 +3670,7 @@ sub _handle_rc_search_history_command { } # Found it. Put it in the buffer, print it, and process it. - $DB::cmd = $hist[$self->i_cmd]; + $DB::cmd = $hist[$i]; print $OUT $DB::cmd, "\n"; redo CMD; } @@ -3673,14 +3681,13 @@ sub _handle_rc_search_history_command { sub _handle_H_command { my $self = shift; - if ($DB::cmd =~ /\AH\b\s*\*/) { + if ($self->cmd_args =~ m#\A\*#) { @hist = @truehist = (); print $OUT "History cleansed\n"; next CMD; } - if (my ($num) - = $DB::cmd =~ /\AH\b\s*(?:-(\d+))?/) { + if (my ($num) = $self->cmd_args =~ /\A(?:-(\d+))?/) { # Anything other than negative numbers is ignored by # the (incorrect) pattern, so this test does nothing. @@ -3701,8 +3708,6 @@ sub _handle_H_command { unless $hist[$i] =~ /^.?$/; } - $self->i_cmd($i); - next CMD; } @@ -3715,7 +3720,7 @@ sub _handle_doc_command { # 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; } @@ -3727,12 +3732,13 @@ sub _handle_p_command { my $print_cmd = 'print {$DB::OUT} '; # p - print (no args): print $_. - if ($DB::cmd eq 'p') { + if ($self->_is_full('p')) { $DB::cmd = $print_cmd . '$_'; } - - # p - print the given expression. - $DB::cmd =~ s/\Ap\b/$print_cmd /; + else { + # p - print the given expression. + $DB::cmd =~ s/\Ap\b/$print_cmd /; + } return; } @@ -3818,7 +3824,7 @@ sub _handle_source_command { my $self = shift; # source - read commands from a file (or pipe!) and execute. - if (my ($sourced_fn) = $DB::cmd =~ /\Asource\s+(.*\S)/) { + if (my $sourced_fn = $self->cmd_args) { if ( open my $fh, $sourced_fn ) { # Opened OK; stick it in the list of file handles. @@ -3827,7 +3833,7 @@ sub _handle_source_command { else { # Couldn't open it. - DB::warn("Can't execute '$sourced_fn': $!\n"); + DB::_db_warn("Can't execute '$sourced_fn': $!\n"); } next CMD; } @@ -3838,9 +3844,10 @@ sub _handle_source_command { sub _handle_enable_disable_commands { my $self = shift; - if (my ($which_cmd, $position) - = $DB::cmd =~ /\A(enable|disable)\s+(\S+)\s*\z/) { + my $which_cmd = $self->cmd_verb; + my $position = $self->cmd_args; + if ($position !~ /\s/) { my ($fn, $line_num); if ($position =~ m{\A\d+\z}) { @@ -3853,7 +3860,7 @@ sub _handle_enable_disable_commands { } else { - DB::warn("Wrong spec for enable/disable argument.\n"); + DB::_db_warn("Wrong spec for enable/disable argument.\n"); } if (defined($fn)) { @@ -3863,7 +3870,7 @@ sub _handle_enable_disable_commands { ); } else { - DB::warn("No breakpoint set at ${fn}:${line_num}\n"); + DB::_db_warn("No breakpoint set at ${fn}:${line_num}\n"); } } @@ -3876,7 +3883,7 @@ sub _handle_enable_disable_commands { sub _handle_save_command { my $self = shift; - if (my ($new_fn) = $DB::cmd =~ /\Asave\s*(.*)\z/) { + if (my $new_fn = $self->cmd_args) { my $filename = $new_fn || '.perl5dbrc'; # default? if ( open my $fh, '>', $filename ) { @@ -3888,7 +3895,7 @@ sub _handle_save_command { print "commands saved in $filename\n"; } else { - DB::warn("Can't save debugger commands in '$new_fn': $!\n"); + DB::_db_warn("Can't save debugger commands in '$new_fn': $!\n"); } next CMD; } @@ -3918,16 +3925,16 @@ sub _handle_sh_command { if ($my_cmd =~ m#\G\z#cgms) { # Run the user's shell. If none defined, run Bourne. # We resume execution when the shell terminates. - DB::system( $ENV{SHELL} || "/bin/sh" ); + DB::_db_system( $ENV{SHELL} || "/bin/sh" ); next CMD; } elsif ($my_cmd =~ m#\G$sh\s*(.*)#cgms) { # System it. - DB::system($1); + DB::_db_system($1); next CMD; } elsif ($my_cmd =~ m#\G\s*(.*)#cgms) { - DB::system( $ENV{SHELL} || "/bin/sh", "-c", $1 ); + DB::_db_system( $ENV{SHELL} || "/bin/sh", "-c", $1 ); next CMD; } } @@ -3952,7 +3959,7 @@ sub _handle_x_command { sub _handle_q_command { my $self = shift; - if ($DB::cmd eq 'q') { + if ($self->_is_full('q')) { $fall_off_end = 1; DB::clean_ENV(); exit $?; @@ -3964,15 +3971,25 @@ sub _handle_q_command { sub _handle_cmd_wrapper_commands { my $self = shift; + DB::cmd_wrapper( $self->cmd_verb, $self->cmd_args, $line ); + next CMD; +} + +sub _handle_special_char_cmd_wrapper_commands { + my $self = shift; + # All of these commands were remapped in perl 5.8.0; # we send them off to the secondary dispatcher (see below). - if (my ($cmd_letter, $my_arg) = $DB::cmd =~ /\A([aAbBeEhilLMoOPvwW]\b|[<>\{]{1,2})\s*(.*)/so) { + if (my ($cmd_letter, $my_arg) = $DB::cmd =~ /\A([<>\{]{1,2})\s*(.*)/so) { DB::cmd_wrapper( $cmd_letter, $my_arg, $line ); next CMD; } return; } + +} ## end DB::Obj + package DB; # The following code may be executed now: @@ -4062,10 +4079,39 @@ use vars qw($deep); # We need to fully qualify the name ("DB::sub") to make "use strict;" # happy. -- Shlomi Fish -sub DB::sub { - # Do not use a regex in this subroutine -> results in corrupted memory - # See: [perl #66110] +sub _indent_print_line_info { + my ($offset, $str) = @_; + + print_lineinfo( ' ' x ($stack_depth - $offset), $str); + + return; +} + +sub _print_frame_message { + my ($al) = @_; + + if ($frame) { + if ($frame & 4) { # Extended frame entry message + _indent_print_line_info(-1, "in "); + + # Why -1? But it works! :-( + # Because print_trace will call add 1 to it and then call + # dump_trace; this results in our skipping -1+1 = 0 stack frames + # in dump_trace. + # + # Now it's 0 because we extracted a function. + print_trace( $LINEINFO, 0, 1, 1, "$sub$al" ); + } + else { + _indent_print_line_info(-1, "entering $sub$al\n" ); + } + } + + return; +} + +sub DB::sub { # lock ourselves under threads lock($DBGR); @@ -4104,22 +4150,26 @@ sub DB::sub { $single |= 4 if $stack_depth == $deep; # If frame messages are on ... - ( - $frame & 4 # Extended frame entry message - ? ( - print_lineinfo( ' ' x ( $stack_depth - 1 ), "in " ), - # Why -1? But it works! :-( - # Because print_trace will call add 1 to it and then call - # dump_trace; this results in our skipping -1+1 = 0 stack frames - # in dump_trace. - print_trace( $LINEINFO, -1, 1, 1, "$sub$al" ) - ) - : print_lineinfo( ' ' x ( $stack_depth - 1 ), "entering $sub$al\n" ) + _print_frame_message($al); + # standard frame entry message - # standard frame entry message - ) - if $frame; + 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; + }; # Determine the sub's return type, and capture appropriately. if (wantarray) { @@ -4135,18 +4185,7 @@ sub DB::sub { # Pop the single-step value back off the stack. $single |= $stack[ $stack_depth-- ]; - # Check for exit trace messages... - ( - $frame & 4 # Extended exit message - ? ( - print_lineinfo( ' ' x $stack_depth, "out " ), - print_trace( $LINEINFO, -1, 1, 1, "$sub$al" ) - ) - : print_lineinfo( ' ' x $stack_depth, "exited $sub$al\n" ) - - # Standard exit message - ) - if $frame & 2; + $print_exit_msg->(); # Print the return info if we need to. if ( $doret eq $stack_depth or $frame & 16 ) { @@ -4156,10 +4195,13 @@ sub DB::sub { my $fh = ( $doret eq $stack_depth ? $OUT : $LINEINFO ); # Indent if we're printing because of $frame tracing. - print $fh ' ' x $stack_depth if $frame & 16; + if ($frame & 16) + { + print {$fh} ' ' x $stack_depth; + } # Print the return value. - print $fh "list context return from $sub:\n"; + print {$fh} "list context return from $sub:\n"; dumpit( $fh, \@ret ); # And don't print it again. @@ -4187,17 +4229,7 @@ sub DB::sub { $single |= $stack[ $stack_depth-- ]; # If we're doing exit messages... - ( - $frame & 4 # Extended messages - ? ( - print_lineinfo( ' ' x $stack_depth, "out " ), - print_trace( $LINEINFO, -1, 1, 1, "$sub$al" ) - ) - : print_lineinfo( ' ' x $stack_depth, "exited $sub$al\n" ) - - # Standard messages - ) - if $frame & 2; + $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 ) { @@ -4252,32 +4284,16 @@ 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. $single |= 4 if $stack_depth == $deep; # If frame messages are on ... - ( - $frame & 4 # Extended frame entry message - ? ( - print_lineinfo( ' ' x ( $stack_depth - 1 ), "in " ), - - # Why -1? But it works! :-( - # Because print_trace will call add 1 to it and then call - # dump_trace; this results in our skipping -1+1 = 0 stack frames - # in dump_trace. - print_trace( $LINEINFO, -1, 1, 1, "$sub$al" ) - ) - : print_lineinfo( ' ' x ( $stack_depth - 1 ), "entering $sub$al\n" ) - - # standard frame entry message - ) - if $frame; - - # Pop the single-step value back off the stack. - $single |= $stack[ $stack_depth-- ]; + _print_frame_message($al); # call the original lvalue sub. &$sub; @@ -5084,40 +5100,46 @@ breakpoint. =cut sub cmd_b_sub { - my ( $subname, $cond ) = @_; - - # Add always-true condition if we have none. - $cond = 1 unless @_ >= 2; + my $subname = shift; + my $cond = @_ ? shift : 1; # If the subname isn't a code reference, qualify it so that # break_subroutine() will work right. - unless ( ref $subname eq 'CODE' ) { + if ( ref($subname) ne 'CODE' ) { - # Not Perl4. - $subname =~ s/\'/::/g; + # Not Perl 4. + $subname =~ s/'/::/g; my $s = $subname; # Put it in this package unless it's already qualified. - $subname = "${package}::" . $subname - unless $subname =~ /::/; + if ($subname !~ /::/) + { + $subname = $package . '::' . $subname; + }; # Requalify it into CORE::GLOBAL if qualifying it into this # package resulted in its not being defined, but only do so # if it really is in CORE::GLOBAL. - $subname = "CORE::GLOBAL::$s" - if not defined &$subname - and $s !~ /::/ - and defined &{"CORE::GLOBAL::$s"}; + my $core_name = "CORE::GLOBAL::$s"; + if ((!defined(&$subname)) + and ($s !~ /::/) + and (defined &{$core_name})) + { + $subname = $core_name; + } # Put it in package 'main' if it has a leading ::. - $subname = "main" . $subname if substr( $subname, 0, 2 ) eq "::"; - - } ## end unless (ref $subname eq 'CODE') + if ($subname =~ /\A::/) + { + $subname = "main" . $subname; + } + } ## end if ( ref($subname) ne 'CODE' ) { # Try to set the breakpoint. if (not eval { break_subroutine( $subname, $cond ); 1 }) { local $\ = ''; - print $OUT $@ and return; + print {$OUT} $@; + return; } return; @@ -5430,7 +5452,8 @@ sub cmd_i { 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( ', ', @@ -5460,190 +5483,264 @@ later. =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(); - # De-Perl4. - $subname =~ s/\'/::/; + # Ooops. Bad scalar. + if ($@) { + print {$OUT} "Error: $@\n"; + next CMD; + } - # Put it in this package unless it starts with ::. - $subname = $package . "::" . $subname unless $subname =~ /::/; + # 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 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"}; + # Call self recursively to really do the command. + return _cmd_l_main( $s ); +} - # Put leading '::' names into 'main::'. - $subname = "main" . $subname if substr( $subname, 0, 2 ) eq "::"; +sub _cmd_l_handle_subname { - # Get name:start-stop from find_sub, and break this up at - # colons. - my @pieces = split( /:/, find_sub($subname) || $sub{$subname} ); + my $s = $subname; - # Pull off start-stop. - my $subrange = pop @pieces; + # De-Perl4. + $subname =~ s/\'/::/; - # If the name contained colons, the split broke it up. - # Put it back together. - $file = join( ':', @pieces ); + # Put it in this package unless it starts with ::. + $subname = $package . "::" . $subname unless $subname =~ /::/; - # 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 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"}; - # Switch debugger's magic structures. - *dbline = $main::{ '_<' . $file }; - $max = $#dbline; - $filename = $file; - } ## end if ($file ne $filename) + # Put leading '::' names into 'main::'. + $subname = "main" . $subname if substr( $subname, 0, 2 ) eq "::"; - # 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/-.*/+/; - } + # Get name:start-stop from find_sub, and break this up at + # colons. + my @pieces = split( /:/, find_sub($subname) || $sub{$subname} ); - # Call self recursively to list the range. - $line = $subrange; - cmd_l( 'l', $subrange ); - } ## end if ($subrange) + # Pull off start-stop. + my $subrange = pop @pieces; - # Couldn't find it. - else { - print $OUT "Subroutine $subname not found.\n"; + # If the name contained colons, the split broke it up. + # Put it back together. + $file = join( ':', @pieces ); + + # 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); - # Determine end point; use end of file if not specified. - my $end = ( !defined $2 ) ? $max : ( $4 ? $4 : $2 ); + # 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 start line. + my $i = $start_match; + + 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 ? ':' : ' ' ); - # Go on to the end, and then stop. - $end = $max if $end > $max; + # 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 - list breakpoints, actions, and watch expressions (command) To list breakpoints, the command has to look determine where all of them are @@ -5659,73 +5756,132 @@ Watchpoints are simpler: we just list the entries in C<@to_watch>. =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' unless $CommandSet eq '580'; # sigh... + if ($CommandSet ne '580') + { + $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? + + # For each line in the file ... + for my $i (1 .. $max) { - # Print the line. - print $OUT " $i:\t", $dbline[$i]; + # We've got something on this line. + if ( defined $dbline{$i} ) { - # Pull out the condition and the action. - my ( $stop, $action ) = split( /\0/, $dbline{$i} ); + # Print the header if we haven't. + if (not $was++) { + print {$OUT} "$file:\n"; + } - # Print the break if there is one and it's wanted. - print $OUT " break if (", $stop, ")\n" - if $stop - and $break_wanted; + # Print the line. + print {$OUT} " $i:\t", $dbline[$i]; - # Print the action if there is one and it's wanted. - print $OUT " action: ", $action, "\n" - if $action - and $action_wanted; + $handle_db_line->($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) + # 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) @@ -5736,24 +5892,9 @@ sub cmd_L { # 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 ) { @@ -5761,6 +5902,7 @@ sub cmd_L { 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) { @@ -5768,6 +5910,8 @@ sub cmd_L { last TO_WATCH if $signal; } } + + return; } ## end sub cmd_L =head3 C - list modules (command) @@ -5796,13 +5940,13 @@ sub cmd_o { # Nonblank. Try to parse and process. if ( $opt =~ /^(\S.*)/ ) { - &parse_options($1); + parse_options($1); } # Blank. List the current option settings. else { for (@options) { - &dump_option($_); + dump_option($_); } } } ## end sub cmd_o @@ -5878,7 +6022,8 @@ sub _add_watch_expr { # 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. @@ -5961,7 +6106,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.*)/) @@ -6016,7 +6161,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 @@ -6111,7 +6260,9 @@ sub postponed { } # If this is a subroutine, let postponed_sub() deal with it. - return &postponed_sub unless ref \$_[0] eq 'GLOB'; + if (ref(\$_[0]) ne 'GLOB') { + return postponed_sub(@_); + } # Not a subroutine. Deal with the file. local *dbline = shift; @@ -6216,7 +6367,7 @@ sub dumpit { my $v = shift; my $maxdepth = shift || $option{dumpDepth}; $maxdepth = -1 unless defined $maxdepth; # -1 means infinite depth - &main::dumpValue( $v, $maxdepth ); + main::dumpValue( $v, $maxdepth ); } ## end if (defined &main::dumpValue) # Oops, couldn't load dumpvar.pl. @@ -6294,7 +6445,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. @@ -6362,6 +6513,51 @@ stack frame. Each has the following keys and values: =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. + 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; + + 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. @@ -6381,7 +6577,7 @@ sub dump_trace { # 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; @@ -6406,40 +6602,7 @@ sub dump_trace { { # 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. @@ -6449,7 +6612,7 @@ sub dump_trace { # 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. @@ -6510,7 +6673,7 @@ sub action { while ( $action =~ s/\\$// ) { # We have a backslash on the end. Read more. - $action .= &gets; + $action .= gets(); } ## end while ($action =~ s/\\$//) # Return the assembled action. @@ -6555,43 +6718,43 @@ it just reads more input with C and returns it. =cut sub gets { - &readline("cont: "); + return DB::readline("cont: "); } -=head2 C - handle calls to without messing up the debugger +=head2 C<_db_system()> - handle calls to without messing up the debugger The C function assumes that it can just go ahead and use STDIN and STDOUT, but under the debugger, we want it to use the debugger's input and outout filehandles. -C socks away the program's STDIN and STDOUT, and then substitutes +C<_db_system()> socks away the program's STDIN and STDOUT, and then substitutes the debugger's IN and OUT filehandles for them. It does the C call, and then puts everything back again. =cut -sub system { +sub _db_system { # 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" : "" ), @@ -6603,6 +6766,8 @@ sub system { } ## end sub system +*system = \&_db_system; + =head1 TTY MANAGEMENT The subs here do some of the terminal management for multiple debuggers. @@ -6642,7 +6807,7 @@ sub setterm { 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. @@ -6689,7 +6854,7 @@ sub setterm { $term->MinLine(2); - &load_hist(); + load_hist(); if ( $term->Features->{setHistory} and "@hist" ne "?" ) { $term->SetHistory(@hist); @@ -6927,6 +7092,45 @@ sub macosx_get_fork_TTY return $tty; } +=head3 C + +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 a new pair of filehandles, pointing to a new TTY. If impossible, @@ -6952,7 +7156,7 @@ sub create_IN_OUT { # Create a window with IN/OUT handles redirected there # If we know how to get a new TTY, do it! $in will have # the TTY name if get_fork_TTY works. - my $in = &get_fork_TTY if defined &get_fork_TTY; + my $in = get_fork_TTY(@_) if defined &get_fork_TTY; # It used to be that $in = $fork_TTY if defined $fork_TTY; # Backward compatibility @@ -7438,13 +7642,15 @@ assumptions about what filehandles are available. =cut -sub warn { +sub _db_warn { my ($msg) = join( "", @_ ); $msg .= ": $!\n" unless $msg =~ /\n$/; local $\ = ''; print $OUT $msg; } ## end sub warn +*warn = \&_db_warn; + =head1 INITIALIZATION TTY SUPPORT =head2 C @@ -7466,7 +7672,7 @@ sub reset_IN_OUT { # This term can't get a new tty now. Better luck later. elsif ($term) { - &warn("Too late to set IN/OUT filehandles, enabled on next 'R'!\n"); + _db_warn("Too late to set IN/OUT filehandles, enabled on next 'R'!\n"); } # Set the filehndles up as they were. @@ -7475,7 +7681,7 @@ sub reset_IN_OUT { } # 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; @@ -7531,7 +7737,9 @@ sub TTY { # Terminal doesn't support new TTY, or doesn't support readline. # Can't do it now, try restarting. - &warn("Too late to set TTY, enabled on next 'R'!\n") if $term and @_; + if ($term and @_) { + _db_warn("Too late to set TTY, enabled on next 'R'!\n"); + } # Useful if done through PERLDB_OPTS: $console = $tty = shift if @_; @@ -7550,7 +7758,7 @@ we save the value to use it if we're restarted. sub noTTY { if ($term) { - &warn("Too late to set noTTY, enabled on next 'R'!\n") if @_; + _db_warn("Too late to set noTTY, enabled on next 'R'!\n") if @_; } $notty = shift if @_; $notty; @@ -7567,7 +7775,7 @@ the value in case a restart is done so we can change it then. sub ReadLine { if ($term) { - &warn("Too late to set ReadLine, enabled on next 'R'!\n") if @_; + _db_warn("Too late to set ReadLine, enabled on next 'R'!\n") if @_; } $rl = shift if @_; $rl; @@ -7583,7 +7791,7 @@ setting in case the user does a restart. sub RemotePort { if ($term) { - &warn("Too late to set RemotePort, enabled on next 'R'!\n") if @_; + _db_warn("Too late to set RemotePort, enabled on next 'R'!\n") if @_; } $remoteport = shift if @_; $remoteport; @@ -7616,7 +7824,7 @@ debugger remembers the setting in case you restart, though. sub NonStop { if ($term) { - &warn("Too late to set up NonStop mode, enabled on next 'R'!\n") + _db_warn("Too late to set up NonStop mode, enabled on next 'R'!\n") if @_; } $runnonstop = shift if @_; @@ -7625,7 +7833,7 @@ sub NonStop { sub DollarCaretP { if ($term) { - &warn("Some flag changes could not take effect until next 'R'!\n") + _db_warn("Some flag changes could not take effect until next 'R'!\n") if @_; } $^P = parse_DollarCaretP_flags(shift) if @_; @@ -7682,17 +7890,24 @@ sub ornaments { if ( defined $term ) { # We don't want to show warning backtraces, but we do want die() ones. - local ( $warnLevel, $dieLevel ) = ( 0, 1 ); + local $warnLevel = 0; + local $dieLevel = 1; # No ornaments if the terminal doesn't support them. - return '' unless $term->Features->{ornaments}; - eval { $term->ornaments(@_) } || ''; + if (not $term->Features->{ornaments}) { + return ''; + } + + return (eval { $term->ornaments(@_) } || ''); } # Use what was passed in if we can't determine it ourselves. else { $ornaments = shift; + + return $ornaments; } + } ## end sub ornaments =head2 C @@ -7712,10 +7927,10 @@ sub recallCommand { } # Build it into a printable version. - $prc = $rc; # Copy it + $prc = $rc; # Copy it $prc =~ s/\\b$//; # Remove trailing \b $prc =~ s/\\(.)/$1/g; # Remove escapes - $prc; # Return the printable version + return $prc; # Return the printable version } ## end sub recallCommand =head2 C - where the line number information goes @@ -7739,10 +7954,12 @@ sub LineInfo { # If this is a pipe, the stream points to a slave editor. $slave_editor = ( $stream =~ /^\|/ ); + my $new_lineinfo_fh; # Open it up and unbuffer it. - open( LINEINFO, $stream ) || &warn("Cannot open '$stream' for write"); - $LINEINFO = \*LINEINFO; - $LINEINFO->autoflush(1); + open ($new_lineinfo_fh , $stream ) + or _db_warn("Cannot open '$stream' for write"); + $LINEINFO = $new_lineinfo_fh; + _autoflush($LINEINFO); } return $lineinfo; @@ -8337,7 +8554,7 @@ sub diesignal { local $Carp::CarpLevel = 2; # mydie + confess # Tell us all about it. - &warn( Carp::longmess("Signal @_") ); + _db_warn( Carp::longmess("Signal @_") ); } # No Carp. Tell us about the signal as best we can. @@ -8396,7 +8613,7 @@ sub dbwarn { # Use the debugger's own special way of printing warnings to print # the stack trace message. - &warn($mess); + _db_warn($mess); } ## end sub dbwarn =head2 C @@ -8418,12 +8635,9 @@ sub dbdie { local $doret = -2; local $SIG{__DIE__} = ''; local $SIG{__WARN__} = ''; - my $i = 0; - my $ineval = 0; - my $sub; if ( $dieLevel > 2 ) { local $SIG{__WARN__} = \&dbwarn; - &warn(@_); # Yell no matter what + _db_warn(@_); # Yell no matter what return; } if ( $dieLevel < 2 ) { @@ -8737,165 +8951,30 @@ sub setman { =head2 C - run the appropriate command to show documentation Accepts a man page name; runs the appropriate command to display it (set up -during debugger initialization). Uses C to avoid mucking up the +during debugger initialization). Uses C<_db_system()> to avoid mucking up the 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 - beos - book - boot - bot - bs2000 - call - ce - cheat - clib - cn - compile - cygwin - data - dbmfilter - debguts - debtut - debug - delta - dgux - diag - doc - dos - dsc - ebcdic - embed - epoc - 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) { - &system("$doccmd $doccmd"); + _db_system("$doccmd $doccmd"); return; } # this way user can override, like with $doccmd="man -Mwhatever" # or even just "man " to disable the path check. - unless ( $doccmd eq 'man' ) { - &system("$doccmd $page"); + if ( $doccmd ne 'man' ) { + _db_system("$doccmd $page"); return; } $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/; @@ -8903,8 +8982,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( @@ -8917,20 +8995,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 @@ -9011,7 +9096,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. @@ -9357,7 +9442,7 @@ If the package is C<::> (C
), 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 * @@ -9576,9 +9661,9 @@ sub rerun { my @temp = @truehist; # store push(@DB::typeahead, @truehist); # saved @truehist = @hist = (); # flush - @args = &restart(); # setup - &get_list("PERLDB_HIST"); # clean - &set_list("PERLDB_HIST", @temp); # reset + @args = restart(); # setup + get_list("PERLDB_HIST"); # clean + set_list("PERLDB_HIST", @temp); # reset } return @args; } @@ -9710,46 +9795,50 @@ variable via C. # 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) @@ -9819,7 +9908,7 @@ END { # Do not stop in at_exit() and destructors on exit: if ($fall_off_end or $runnonstop) { - &save_hist(); + save_hist(); } else { $DB::single = 1; DB::fake::at_exit(); @@ -9913,7 +10002,7 @@ sub cmd_pre580_b { if ( $cmd =~ /^load\b\s*(.*)/ ) { my $file = $1; $file =~ s/\s+$//; - &cmd_b_load($file); + cmd_b_load($file); } # b compile|postpone [] @@ -9946,13 +10035,13 @@ sub cmd_pre580_b { elsif ( $cmd =~ /^([':A-Za-z_][':\w]*(?:\[.*\])?)\s*(.*)/ ) { my $subname = $1; my $cond = length $2 ? $2 : '1'; - &cmd_b_sub( $subname, $cond ); + cmd_b_sub( $subname, $cond ); } # b []. elsif ( $cmd =~ /^(\d*)\s*(.*)/ ) { my $i = $1 || $dbline; my $cond = length $2 ? $2 : '1'; - &cmd_b_line( $i, $cond ); + cmd_b_line( $i, $cond ); } } ## end sub cmd_pre580_b @@ -10099,7 +10188,8 @@ sub cmd_pre580_W { # 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. @@ -10131,7 +10221,7 @@ sub cmd_pre590_prepost { my $line = shift || '*'; my $dbline = shift; - return &cmd_prepost( $cmd, $line, $dbline ); + return cmd_prepost( $cmd, $line, $dbline ); } ## end sub cmd_pre590_prepost =head2 C @@ -10153,7 +10243,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 = [];