X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/8baafc8b781dd780aec95fc17e14c1ea091af527..db66d27d1fc06a2481f86ac632dc733a286b6d18:/lib/perl5db.pl diff --git a/lib/perl5db.pl b/lib/perl5db.pl index 3efe025..330f7a9 100644 --- a/lib/perl5db.pl +++ b/lib/perl5db.pl @@ -186,7 +186,7 @@ uses this hash to determine where breakpoints have been set. Any true value is considered to be a breakpoint; C uses C<$break_condition\0$action>. Values are magical in numeric context: 1 if the line is breakable, 0 if not. -The scalar C<${"_<$filename"}> simply contains the string C<<< _<$filename> >>>. +The scalar C<${"_<$filename"}> simply contains the string C<$filename>. This is also the case for evaluated strings that contain subroutines, or which are currently being executed. The $filename for Ced strings looks like C<(eval 34). @@ -523,7 +523,7 @@ BEGIN { # Debugger for Perl 5.00x; perl5db.pl patch level: use vars qw($VERSION $header); -$VERSION = '1.39_05'; +$VERSION = '1.39_06'; $header = "perl5db.pl version $VERSION"; @@ -643,7 +643,6 @@ use vars qw( $ini_warn $maxtrace $od - $onetimedumpDepth @options $osingle $otrace @@ -674,6 +673,7 @@ our ( $ImmediateStop, $line, $onetimeDump, + $onetimedumpDepth, %option, $OUT, $packname, @@ -866,8 +866,7 @@ BEGIN { lock($DBGR); print "Threads support enabled\n"; } else { - *lock = sub(*) {}; - *share = sub(*) {}; + *share = sub(\[$@%]) {}; } } @@ -893,9 +892,7 @@ BEGIN { } # without threads, $filename is not defined until DB::DB is called -foreach my $k (keys (%INC)) { - share(\$main::{'_<'.$filename}) if defined $filename; -}; +share($main::{'_<'.$filename}) if defined $filename; # Command-line + PERLLIB: # Save the contents of @INC before they are modified elsewhere. @@ -1548,7 +1545,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 @@ -1571,11 +1568,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. @@ -1746,7 +1738,6 @@ see what's happening in any given command. use vars qw( $action $cmd - $fall_off_end $file $filename_ini $finished @@ -1754,7 +1745,6 @@ use vars qw( $level $max $package - $sh $try ); @@ -1762,9 +1752,11 @@ our ( %alias, $doret, $end, + $fall_off_end, $incr, $laststep, $rc, + $sh, $stack_depth, @stack, @to_watch, @@ -1837,17 +1829,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 @@ -1896,7 +1894,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. @@ -1917,12 +1915,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 @@ -1945,7 +1943,7 @@ sub _DB__handle_y_command { # Oops. Can't find it. if (my $Err = $@) { $Err =~ s/ at .*//; - DB::warn($Err); + _db_warn($Err); next CMD; } @@ -1966,16 +1964,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... @@ -1998,13 +1996,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. @@ -2017,9 +2015,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. @@ -2050,22 +2051,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; } @@ -2098,7 +2099,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); @@ -2122,7 +2123,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); @@ -2134,11 +2137,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,6 +2238,230 @@ sub _DB__handle_question_mark_command { return; } +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 ($cmd_cmd eq 'rerun' or $cmd_params eq '') { + my @args = ($cmd_cmd eq 'R' ? restart() : rerun($cmd_params)); + + # Close all non-system fds for a clean restart. A more + # correct method would be to close all fds that were not + # open when the process started, but this seems to be + # hard. See "debugger 'R'estart and open database + # connections" on p5p. + + my $max_fd = 1024; # default if POSIX can't be loaded + if (eval { require POSIX }) { + eval { $max_fd = POSIX::sysconf(POSIX::_SC_OPEN_MAX()) }; + } + + if (defined $max_fd) { + foreach ($^F+1 .. $max_fd-1) { + next unless open FD_TO_CLOSE, "<&=$_"; + close(FD_TO_CLOSE); + } + } + + # And run Perl again. We use exec() to keep the + # PID stable (and that way $ini_pids is still valid). + exec(@args) or print {$OUT} "exec failed: $!\n"; + + last CMD; + } + + return; +} + +sub _DB__handle_run_command_in_pager_command { + my ($obj) = @_; + + if ($cmd =~ m#\A\|\|?\s*[^|]#) { + if ( $pager =~ /^\|/ ) { + + # Default pager is into a pipe. Redirect I/O. + open( SAVEOUT, ">&STDOUT" ) + || _db_warn("Can't save STDOUT"); + open( STDOUT, ">&OUT" ) + || _db_warn("Can't redirect STDOUT"); + } ## end if ($pager =~ /^\|/) + else { + + # Not into a pipe. STDOUT is safe. + open( SAVEOUT, ">&OUT" ) || _db_warn("Can't save DB::OUT"); + } + + # Fix up environment to record we have less if so. + fix_less(); + + unless ( $obj->piped(scalar ( open( OUT, $pager ) ) ) ) { + + # Couldn't open pipe 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"); + open( STDOUT, ">&SAVEOUT" ) + || _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"); + } + next CMD; + } ## end unless ($piped = open(OUT,... + + # Set up broken-pipe handler if necessary. + $SIG{PIPE} = \&DB::catch + if $pager =~ /^\|/ + && ( "" eq $SIG{PIPE} || "DEFAULT" eq $SIG{PIPE} ); + + OUT->autoflush(1); + # Save current filehandle, and put it back. + $obj->selected(scalar( select(OUT) )); + # Don't put it back if pager was a pipe. + if ($cmd !~ /\A\|\|/) + { + select($obj->selected()); + $obj->selected(""); + } + + # Trim off the pipe symbols and run the command now. + $cmd =~ s#\A\|+\s*##; + redo PIPE; + } + + return; +} + +sub _DB__handle_m_command { + my ($obj) = @_; + + if ($cmd =~ s#\Am\s+([\w:]+)\s*\z# #) { + methods($1); + next CMD; + } + + # m expr - set up DB::eval to do the work + if ($cmd =~ s#\Am\b# #) { # Rest gets done by DB::eval() + $onetimeDump = 'methods'; # method output gets used there + } + + return; +} + +sub _DB__at_end_of_every_command { + my ($obj) = @_; + + # At the end of every command: + if ($obj->piped) { + + # Unhook the pipe mechanism now. + if ( $pager =~ /^\|/ ) { + + # No error from the child. + $? = 0; + + # we cannot warn here: the handle is missing --tchrist + close(OUT) || print SAVEOUT "\nCan't close DB::OUT\n"; + + # most of the $? crud was coping with broken cshisms + # $? is explicitly set to 0, so this never runs. + if ($?) { + print SAVEOUT "Pager '$pager' failed: "; + if ( $? == -1 ) { + print SAVEOUT "shell returned -1\n"; + } + elsif ( $? >> 8 ) { + print SAVEOUT ( $? & 127 ) + ? " (SIG#" . ( $? & 127 ) . ")" + : "", ( $? & 128 ) ? " -- core dumped" : "", "\n"; + } + else { + print SAVEOUT "status ", ( $? >> 8 ), "\n"; + } + } ## end if ($?) + + # Reopen filehandle for our output (if we can) and + # restore STDOUT (if we can). + open( OUT, ">&STDOUT" ) || _db_warn("Can't restore DB::OUT"); + open( STDOUT, ">&SAVEOUT" ) + || _db_warn("Can't restore STDOUT"); + + # Turn off pipe exception handler if necessary. + $SIG{PIPE} = "DEFAULT" if $SIG{PIPE} eq \&DB::catch; + + # Will stop ignoring SIGPIPE if done like nohup(1) + # does SIGINT but Perl doesn't give us a choice. + } ## end if ($pager =~ /^\|/) + else { + + # Non-piped "pager". Just restore STDOUT. + open( OUT, ">&SAVEOUT" ) || _db_warn("Can't restore DB::OUT"); + } + + # Close filehandle pager was using, restore the normal one + # if necessary, + close(SAVEOUT); + + if ($obj->selected() ne "") { + select($obj->selected); + $obj->selected(""); + } + + # No pipes now. + $obj->piped(""); + } ## end if ($piped) + + return; +} + +# 't' is type. +# 'm' is method. +# 'v' is the value (i.e: method name or subroutine ref). +# 's' is subroutine. +my %cmd_lookup = +( + '-' => { 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 P v w W)), +); + sub DB { # lock the debugger and get the thread id for the prompt @@ -2244,12 +2471,15 @@ sub DB { my ($prefix, $after, $infix); my $pat; my $explicit_stop; + my $piped; + my $selected; if ($ENV{PERL5DB_THREADED}) { $tid = eval { "[".threads->tid."]" }; } - my $i; + my $cmd_verb; + my $cmd_args; my $obj = DB::Obj->new( { @@ -2258,8 +2488,11 @@ 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, }, ); @@ -2267,7 +2500,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 @@ -2458,8 +2691,6 @@ the new command. This is faster, but perhaps a bit more convoluted. # # If we have a terminal for input, and we get something back # from readline(), keep on processing. - my $piped; - my $selected; CMD: while (_DB__read_next_cmd($tid)) @@ -2507,7 +2738,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 @@ -2519,7 +2750,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. @@ -2530,13 +2761,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; } - } ## end if ($alias{$i}) + _DB__trim_command_and_return_first_component($obj); + } ## end if ($alias{$cmd_verb}) =head3 MAIN-LINE COMMANDS @@ -2551,10 +2783,20 @@ environment, and executing with the last value of C<$?>. =cut - if ($cmd eq 'q') { - $fall_off_end = 1; - clean_ENV(); - exit $?; + # 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') { + $obj->$val(); + } + elsif ($type eq 's') { + $val->($obj); + } } =head4 C - trace [n] @@ -2562,18 +2804,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 @@ -2583,58 +2817,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 - - if ($cmd =~ s#\Ax\b# #) { # Remainder gets done by DB::eval() - $onetimeDump = 'dump'; # main::dumpvar shows the output - - # handle special "x 3 blah" syntax XXX propagate - # doc back to special variables. - if ( $cmd =~ s#\A\s*(\d+)(?=\s)# #) { - $onetimedumpDepth = $1; - } - } - =head4 C - print methods Just uses C to determine what methods are available. -=cut - - if ($cmd =~ s#\Am\s+([\w:]+)\s*\z# #) { - methods($1); - next CMD; - } - - # m expr - set up DB::eval to do the work - if ($cmd =~ s#\Am\b# #) { # Rest gets done by DB::eval() - $onetimeDump = 'methods'; # method output gets used there - } - =head4 C - switch files -=cut - - _DB__handle_f_command(); +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, @@ -2642,11 +2842,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 @@ -2656,24 +2851,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). - if (my ($cmd_letter, $my_arg) = $cmd =~ /\A([aAbBeEhilLMoOPvwW]\b|[<>\{]{1,2})\s*(.*)/so) { - &cmd_wrapper( $cmd_letter, $my_arg, $line ); - next CMD; - } - =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 @@ -2688,20 +2870,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 @@ -2709,11 +2882,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 @@ -2722,35 +2890,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 @@ -2783,19 +2934,12 @@ 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 - # $sh$sh - run a shell command (if it's all ASCII). - # Can't run shell commands with Unicode in the debugger, hmm. - if (my ($arg) = $cmd =~ m#\A$sh$sh\s*(.*)#ms) { - - # System it. - DB::system($arg); - next CMD; - } + $obj->_handle_sh_command; =head4 C<$rc I $rc> - Search command history @@ -2808,45 +2952,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 - # $sh - start a shell. - if ($cmd =~ /\A$sh\z/) { - - # Run the user's shell. If none defined, run Bourne. - # We resume execution when the shell terminates. - &system( $ENV{SHELL} || "/bin/sh" ); - next CMD; - } - =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. - -=cut - - # $sh command - start a shell and run a command in it. - if (my ($arg) = $cmd =~ m#\A$sh\s*(.*)#ms) { - - # XXX: using csh or tcsh destroys sigint retvals! - #&system($1); # use this instead - - # use the user's shell, or Bourne if none defined. - &system( $ENV{SHELL} || "/bin/sh", "-c", $arg ); - next CMD; - } +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. @@ -2860,36 +2978,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), @@ -2897,11 +2998,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. @@ -2910,39 +3006,6 @@ Restart the debugger session. Return to any given position in the B-history list -=cut - - # R - restart execution. - # rerun - controlled restart execution. - if (my ($cmd_cmd, $cmd_params) = - $cmd =~ /\A((?:R)|(?:rerun\s*(.*)))\z/) { - my @args = ($cmd_cmd eq 'R' ? restart() : rerun($cmd_params)); - - # Close all non-system fds for a clean restart. A more - # correct method would be to close all fds that were not - # open when the process started, but this seems to be - # hard. See "debugger 'R'estart and open database - # connections" on p5p. - - my $max_fd = 1024; # default if POSIX can't be loaded - if (eval { require POSIX }) { - eval { $max_fd = POSIX::sysconf(POSIX::_SC_OPEN_MAX()) }; - } - - if (defined $max_fd) { - foreach ($^F+1 .. $max_fd-1) { - next unless open FD_TO_CLOSE, "<&=$_"; - close(FD_TO_CLOSE); - } - } - - # And run Perl again. We use exec() to keep the - # PID stable (and that way $ini_pids is still valid). - exec(@args) || print $OUT "exec failed: $!\n"; - - last CMD; - } - =head4 C<|, ||> - pipe output through the pager. For C<|>, we save C (the debugger's output filehandle) and C @@ -2958,61 +3021,7 @@ reading another. =cut # || - run command in the pager, with output to DB::OUT. - if ($cmd =~ m#\A\|\|?\s*[^|]#) { - if ( $pager =~ /^\|/ ) { - - # Default pager is into a pipe. Redirect I/O. - open( SAVEOUT, ">&STDOUT" ) - || &warn("Can't save STDOUT"); - open( STDOUT, ">&OUT" ) - || &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"); - } - - # Fix up environment to record we have less if so. - fix_less(); - - unless ( $piped = open( OUT, $pager ) ) { - - # Couldn't open pipe to pager. - &warn("Can't pipe output to '$pager'"); - if ( $pager =~ /^\|/ ) { - - # Redirect I/O back again. - open( OUT, ">&STDOUT" ) # XXX: lost message - || &warn("Can't restore DB::OUT"); - open( STDOUT, ">&SAVEOUT" ) - || &warn("Can't restore STDOUT"); - close(SAVEOUT); - } ## end if ($pager =~ /^\|/) - else { - - # Redirect I/O. STDOUT already safe. - open( OUT, ">&STDOUT" ) # XXX: lost message - || &warn("Can't restore DB::OUT"); - } - next CMD; - } ## end unless ($piped = open(OUT,... - - # Set up broken-pipe handler if necessary. - $SIG{PIPE} = \&DB::catch - if $pager =~ /^\|/ - && ( "" eq $SIG{PIPE} || "DEFAULT" eq $SIG{PIPE} ); - - OUT->autoflush(1); - # Save current filehandle, and put it back. - $selected = select(OUT); - # Don't put it back if pager was a pipe. - select($selected), $selected = "" unless $cmd =~ /^\|\|/; - - # Trim off the pipe symbols and run the command now. - $cmd =~ s#\A\|+\s*##; - redo PIPE; - } + _DB__handle_run_command_in_pager_command($obj); =head3 END OF COMMAND PARSING @@ -3022,25 +3031,11 @@ any variables we might want to address in the C package. =cut - # t - turn trace on. - if ($cmd =~ s#\At\s+(\d+)?#\$DB::trace |= 1;\n#) { - my $trace_arg = $1; - $trace_to_depth = $trace_arg ? $stack_depth||0 + $1 : 1E9; - } - - # s - single-step. Remember the last command was 's'. - if ($cmd =~ s/\As\s/\$DB::single = 1;\n/) { - $laststep = 's'; - } - - # n - single-step, but not into subs. Remember last command - # was 'n'. - if ($cmd =~ s#\An\s#\$DB::single = 2;\n#) { - $laststep = 'n'; - } - } # 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"; @@ -3073,62 +3068,7 @@ our standard filehandles for input and output. =cut continue { # CMD: - - # At the end of every command: - if ($piped) { - - # Unhook the pipe mechanism now. - if ( $pager =~ /^\|/ ) { - - # No error from the child. - $? = 0; - - # we cannot warn here: the handle is missing --tchrist - close(OUT) || print SAVEOUT "\nCan't close DB::OUT\n"; - - # most of the $? crud was coping with broken cshisms - # $? is explicitly set to 0, so this never runs. - if ($?) { - print SAVEOUT "Pager '$pager' failed: "; - if ( $? == -1 ) { - print SAVEOUT "shell returned -1\n"; - } - elsif ( $? >> 8 ) { - print SAVEOUT ( $? & 127 ) - ? " (SIG#" . ( $? & 127 ) . ")" - : "", ( $? & 128 ) ? " -- core dumped" : "", "\n"; - } - else { - print SAVEOUT "status ", ( $? >> 8 ), "\n"; - } - } ## end if ($?) - - # Reopen filehandle for our output (if we can) and - # restore STDOUT (if we can). - open( OUT, ">&STDOUT" ) || &warn("Can't restore DB::OUT"); - open( STDOUT, ">&SAVEOUT" ) - || &warn("Can't restore STDOUT"); - - # Turn off pipe exception handler if necessary. - $SIG{PIPE} = "DEFAULT" if $SIG{PIPE} eq \&DB::catch; - - # Will stop ignoring SIGPIPE if done like nohup(1) - # does SIGINT but Perl doesn't give us a choice. - } ## end if ($pager =~ /^\|/) - else { - - # Non-piped "pager". Just restore STDOUT. - open( OUT, ">&SAVEOUT" ) || &warn("Can't restore DB::OUT"); - } - - # Close filehandle pager was using, restore the normal one - # if necessary, - close(SAVEOUT); - select($selected), $selected = "" unless $selected eq ""; - - # No pipes now. - $piped = ""; - } ## end if ($piped) + _DB__at_end_of_every_command($obj); } # CMD: =head3 COMMAND LOOP TERMINATION @@ -3179,7 +3119,8 @@ sub _init { { no strict 'refs'; foreach my $slot_name (qw( - after explicit_stop infix pat position prefix i_cmd + after explicit_stop infix pat piped position prefix selected cmd_verb + cmd_args )) { my $slot = $slot_name; *{$slot} = sub { @@ -3291,6 +3232,12 @@ sub _curr_line { return $DB::dbline[$line]; } +sub _is_full { + my ($self, $letter) = @_; + + return ($DB::cmd eq $letter); +} + sub _DB__grab_control { my $self = shift; @@ -3397,7 +3344,11 @@ number information, and print that. } sub _handle_t_command { - if (my ($levels) = $DB::cmd =~ /\At(?:\s+(\d+))?\z/) { + my $self = shift; + + my $levels = $self->cmd_args(); + + if ((!length($levels)) or ($levels !~ /\D/)) { $trace ^= 1; local $\ = ''; $DB::trace_to_depth = $levels ? $stack_depth + $levels : 1E9; @@ -3413,8 +3364,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; @@ -3441,12 +3394,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"; } @@ -3475,7 +3429,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} @@ -3505,8 +3459,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; @@ -3515,6 +3470,7 @@ sub _handle_dash_command { # Generate and execute a "l +" command (handled below). $DB::cmd = 'l ' . ($start) . '+'; + redo CMD; } return; } @@ -3535,9 +3491,12 @@ 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); } + else { + $self->_n_or_s_and_arg_commands_generic($letter, $new_val); + } return; } @@ -3556,8 +3515,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(); @@ -3574,7 +3534,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; } @@ -3583,16 +3545,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; } @@ -3613,12 +3577,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. @@ -3642,7 +3607,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: @@ -3651,9 +3616,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"; @@ -3661,7 +3624,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; } @@ -3672,14 +3635,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. @@ -3700,8 +3662,6 @@ sub _handle_H_command { unless $hist[$i] =~ /^.?$/; } - $self->i_cmd($i); - next CMD; } @@ -3726,12 +3686,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; } @@ -3817,7 +3778,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. @@ -3826,7 +3787,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; } @@ -3837,9 +3798,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}) { @@ -3852,43 +3814,128 @@ 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)) { + if (DB::_has_breakpoint_data_ref($fn, $line_num)) { + DB::_set_breakpoint_enabled_status($fn, $line_num, + ($which_cmd eq 'enable' ? 1 : '') + ); + } + else { + DB::_db_warn("No breakpoint set at ${fn}:${line_num}\n"); + } + } + + next CMD; + } + + return; +} + +sub _handle_save_command { + my $self = shift; + + if (my $new_fn = $self->cmd_args) { + my $filename = $new_fn || '.perl5dbrc'; # default? + if ( open my $fh, '>', $filename ) { + + # chomp to remove extraneous newlines from source'd files + chomp( my @truelist = + map { m/\A\s*(save|source)/ ? "#$_" : $_ } + @truehist ); + print {$fh} join( "\n", @truelist ); + print "commands saved in $filename\n"; + } + else { + DB::_db_warn("Can't save debugger commands in '$new_fn': $!\n"); + } + next CMD; + } + + return; +} + +sub _n_or_s_and_arg_commands_generic { + my ($self, $letter, $new_val) = @_; + + # s - single-step. Remember the last command was 's'. + if ($DB::cmd =~ s#\A\Q$letter\E\s#\$DB::single = $new_val;\n#) { + $laststep = $letter; + } + + return; +} + +sub _handle_sh_command { + my $self = shift; + + # $sh$sh - run a shell command (if it's all ASCII). + # Can't run shell commands with Unicode in the debugger, hmm. + my $my_cmd = $DB::cmd; + if ($my_cmd =~ m#\A$sh#gms) { + + 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::_db_system( $ENV{SHELL} || "/bin/sh" ); + next CMD; + } + elsif ($my_cmd =~ m#\G$sh\s*(.*)#cgms) { + # System it. + DB::_db_system($1); + next CMD; + } + elsif ($my_cmd =~ m#\G\s*(.*)#cgms) { + DB::_db_system( $ENV{SHELL} || "/bin/sh", "-c", $1 ); + next CMD; } + } +} - if (defined($fn)) { - if (DB::_has_breakpoint_data_ref($fn, $line_num)) { - DB::_set_breakpoint_enabled_status($fn, $line_num, - ($which_cmd eq 'enable' ? 1 : '') - ); - } - else { - DB::warn("No breakpoint set at ${fn}:${line_num}\n"); - } +sub _handle_x_command { + my $self = shift; + + if ($DB::cmd =~ s#\Ax\b# #) { # Remainder gets done by DB::eval() + $onetimeDump = 'dump'; # main::dumpvar shows the output + + # handle special "x 3 blah" syntax XXX propagate + # doc back to special variables. + if ( $DB::cmd =~ s#\A\s*(\d+)(?=\s)# #) { + $onetimedumpDepth = $1; } + } - next CMD; + return; +} + +sub _handle_q_command { + my $self = shift; + + if ($self->_is_full('q')) { + $fall_off_end = 1; + DB::clean_ENV(); + exit $?; } return; } -sub _handle_save_command { +sub _handle_cmd_wrapper_commands { my $self = shift; - if (my ($new_fn) = $DB::cmd =~ /\Asave\s*(.*)\z/) { - my $filename = $new_fn || '.perl5dbrc'; # default? - if ( open my $fh, '>', $filename ) { + DB::cmd_wrapper( $self->cmd_verb, $self->cmd_args, $line ); + next CMD; +} - # chomp to remove extraneous newlines from source'd files - chomp( my @truelist = - map { m/\A\s*(save|source)/ ? "#$_" : $_ } - @truehist ); - print {$fh} join( "\n", @truelist ); - print "commands saved in $filename\n"; - } - else { - DB::warn("Can't save debugger commands in '$new_fn': $!\n"); - } +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([<>\{]{1,2})\s*(.*)/so) { + DB::cmd_wrapper( $cmd_letter, $my_arg, $line ); next CMD; } @@ -3984,6 +4031,38 @@ use vars qw($deep); # We need to fully qualify the name ("DB::sub") to make "use strict;" # happy. -- Shlomi Fish + +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 { # Do not use a regex in this subroutine -> results in corrupted memory # See: [perl #66110] @@ -4026,22 +4105,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) { @@ -4057,18 +4140,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 ) { @@ -4078,10 +4150,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. @@ -4109,17 +4184,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 ) { @@ -4181,22 +4246,7 @@ sub lsub : lvalue { $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; + _print_frame_message($al); # Pop the single-step value back off the stack. $single |= $stack[ $stack_depth-- ]; @@ -4363,7 +4413,7 @@ sub cmd_wrapper { # default to the older version of the command. my $call = 'cmd_' . ( $set{$CommandSet}{$cmd} - || ( $cmd =~ /^[<>{]+/o ? 'prepost' : $cmd ) ); + || ( $cmd =~ /\A[<>{]+/o ? 'prepost' : $cmd ) ); # Call the command subroutine, call it by name. return __PACKAGE__->can($call)->( $cmd, $line, $dblineno ); @@ -5006,40 +5056,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; @@ -5382,190 +5438,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(); + + # Ooops. Bad scalar. + if ($@) { + print {$OUT} "Error: $@\n"; + next CMD; + } - # De-Perl4. - $subname =~ s/\'/::/; + # 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 this package unless it starts with ::. - $subname = $package . "::" . $subname unless $subname =~ /::/; + # Call self recursively to really do the command. + return _cmd_l_main( $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"}; +sub _cmd_l_handle_subname { - # Put leading '::' names into 'main::'. - $subname = "main" . $subname if substr( $subname, 0, 2 ) eq "::"; + my $s = $subname; - # Get name:start-stop from find_sub, and break this up at - # colons. - my @pieces = split( /:/, find_sub($subname) || $sub{$subname} ); + # De-Perl4. + $subname =~ s/\'/::/; - # Pull off start-stop. - my $subrange = pop @pieces; + # Put it in this package unless it starts with ::. + $subname = $package . "::" . $subname unless $subname =~ /::/; - # If the name contained colons, the split broke it up. - # Put it back together. - $file = join( ':', @pieces ); + # 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"}; - # 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 leading '::' names into 'main::'. + $subname = "main" . $subname if substr( $subname, 0, 2 ) eq "::"; - # Switch debugger's magic structures. - *dbline = $main::{ '_<' . $file }; - $max = $#dbline; - $filename = $file; - } ## end if ($file ne $filename) + # Get name:start-stop from find_sub, and break this up at + # colons. + my @pieces = split( /:/, find_sub($subname) || $sub{$subname} ); - # 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/-.*/+/; - } + # Pull off start-stop. + my $subrange = pop @pieces; - # Call self recursively to list the range. - $line = $subrange; - cmd_l( 'l', $subrange ); - } ## end if ($subrange) + # If the name contained colons, the split broke it up. + # Put it back together. + $file = join( ':', @pieces ); - # Couldn't find it. - else { - print $OUT "Subroutine $subname not found.\n"; + # 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); + + # 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; - # Determine end point; use end of file if not specified. - my $end = ( !defined $2 ) ? $max : ( $4 ? $4 : $2 ); + 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} ); + } - # Go on to the end, and then stop. - $end = $max if $end > $max; + # ==> 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 ? ':' : ' ' ); - # Determine start line. - my $i = $2; - $i = $line if $i eq '.'; - $i = 1 if $i < 1; - $incr = $end - $i; + # Add break and action indicators. + $arrow .= 'b' if $stop; + $arrow .= 'a' if $action; - # 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; + # Print the line. + print {$OUT} "$i$arrow\t", $dbline[$i]; + + # 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); + + return; +} - # Check for breakpoints and actions. - my ( $stop, $action ); - ( $stop, $action ) = split( /\0/, $dbline{$i} ) - if $dbline{$i}; +sub _cmd_l_main { + my $spec = shift; - # ==> 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 ? ':' : ' ' ); + # If this is '-something', delete any spaces after the dash. + $spec =~ s/\A-\s*\z/-/; - # Add break and action indicators. - $arrow .= 'b' if $stop; - $arrow .= 'a' if $action; + # 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); + } - # 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\$\.]+))?)?/) + 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 @@ -5581,73 +5711,105 @@ 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? - # Print the line. - print $OUT " $i:\t", $dbline[$i]; + # For each line in the file ... + for my $i (1 .. $max) { - # Pull out the condition and the action. - my ( $stop, $action ) = split( /\0/, $dbline{$i} ); + # We've got something on this line. + if ( defined $dbline{$i} ) { - # Print the break if there is one and it's wanted. - print $OUT " break if (", $stop, ")\n" - if $stop - and $break_wanted; + # Print the header if we haven't. + if (not $was++) { + print {$OUT} "$file:\n"; + } - # Print the action if there is one and it's wanted. - print $OUT " action: ", $action, "\n" - if $action - and $action_wanted; + # Print the line. + print {$OUT} " $i:\t", $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) + $handle_db_line->($dbline{$i}); + + # 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 { + 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); } ## end if ($break_wanted or $action_wanted) # 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) @@ -5658,22 +5820,23 @@ sub cmd_L { # If there are any, list them. if ( @have and ( $break_wanted or $action_wanted ) ) { - print $OUT "Postponed breakpoints in files:\n"; + print {$OUT} "Postponed breakpoints in files:\n"; + POSTPONED_SCANS: for my $file ( keys %postponed_file ) { my $db = $postponed_file{$file}; - print $OUT " $file:\n"; + 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; + print {$OUT} " $line:\n"; + + $handle_db_line->($db->{$line}); + + if ($signal) { + last POSTPONED_SCANS; + } } ## end for $line (sort { $a <=>... - last if $signal; + if ($signal) { + last POSTPONED_SCANS; + } } ## end for $file (keys %postponed_file) } ## end if (@have and ($break_wanted... if ( %break_on_load and $break_wanted ) { @@ -5718,13 +5881,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 @@ -6033,7 +6196,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; @@ -6138,7 +6303,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. @@ -6432,7 +6597,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. @@ -6477,43 +6642,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" : "" ), @@ -6525,6 +6690,8 @@ sub system { } ## end sub system +*system = \&_db_system; + =head1 TTY MANAGEMENT The subs here do some of the terminal management for multiple debuggers. @@ -6611,7 +6778,7 @@ sub setterm { $term->MinLine(2); - &load_hist(); + load_hist(); if ( $term->Features->{setHistory} and "@hist" ne "?" ) { $term->SetHistory(@hist); @@ -6874,7 +7041,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 @@ -7360,13 +7527,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 @@ -7388,7 +7557,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. @@ -7453,7 +7622,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 @_; @@ -7472,7 +7643,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; @@ -7489,7 +7660,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; @@ -7505,7 +7676,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; @@ -7538,7 +7709,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 @_; @@ -7547,7 +7718,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 @_; @@ -7604,17 +7775,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 @@ -7634,10 +7812,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 @@ -7661,9 +7839,11 @@ 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; + open ($new_lineinfo_fh , $stream ) + or _db_warn("Cannot open '$stream' for write"); + $LINEINFO = $new_lineinfo_fh; $LINEINFO->autoflush(1); } @@ -8259,7 +8439,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. @@ -8318,7 +8498,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 @@ -8340,12 +8520,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 ) { @@ -8659,7 +8836,7 @@ 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 @@ -8687,7 +8864,6 @@ my %_is_in_pods = (map { $_ => 1 } apio api artistic - beos book boot bot @@ -8712,7 +8888,6 @@ my %_is_in_pods = (map { $_ => 1 } dsc ebcdic embed - epoc faq1 faq2 faq3 @@ -8802,14 +8977,14 @@ my %_is_in_pods = (map { $_ => 1 } 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; } @@ -9498,9 +9673,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; } @@ -9741,7 +9916,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(); @@ -9835,7 +10010,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 [] @@ -9868,13 +10043,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 @@ -10053,7 +10228,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