X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/7019653802c5a3ebbe514d94777bca898d9a56c1..be43a6d374e53ec6fde940ef937916923fc94752:/lib/perl5db.pl diff --git a/lib/perl5db.pl b/lib/perl5db.pl index 9042ab0..cdf8826 100644 --- a/lib/perl5db.pl +++ b/lib/perl5db.pl @@ -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"; @@ -1545,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 @@ -1568,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. @@ -1834,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 @@ -1893,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. @@ -1914,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 @@ -1942,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; } @@ -1963,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... @@ -1995,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. @@ -2014,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. @@ -2047,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; } @@ -2095,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); @@ -2119,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); @@ -2131,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,10 +2241,11 @@ 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 '') { my @args = ($cmd_cmd eq 'R' ? restart() : rerun($cmd_params)); # Close all non-system fds for a clean restart. A more @@ -2277,14 +2284,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 +2300,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,... @@ -2385,9 +2392,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,7 +2405,7 @@ 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"); } # Close filehandle pager was using, restore the normal one @@ -2417,6 +2424,44 @@ sub _DB__at_end_of_every_command { 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 @@ -2433,7 +2478,8 @@ sub DB { $tid = eval { "[".threads->tid."]" }; } - my $i; + my $cmd_verb; + my $cmd_args; my $obj = DB::Obj->new( { @@ -2442,7 +2488,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, @@ -2453,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 @@ -2691,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 @@ -2703,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. @@ -2714,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 @@ -2735,25 +2783,31 @@ environment, and executing with the last value of C<$?>. =cut - $obj->_handle_q_command; + # 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] 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 @@ -2763,42 +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 - - $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(); +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, @@ -2806,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 @@ -2820,21 +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). - $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 @@ -2849,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 @@ -2870,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 @@ -2883,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 @@ -2944,7 +2934,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 @@ -2962,23 +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 =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. @@ -2992,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), @@ -3029,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. @@ -3042,12 +3006,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 @@ -3075,6 +3033,9 @@ 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"; @@ -3158,7 +3119,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 { @@ -3270,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; @@ -3376,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; @@ -3392,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; @@ -3420,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"; } @@ -3454,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} @@ -3484,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; @@ -3494,6 +3470,7 @@ sub _handle_dash_command { # Generate and execute a "l +" command (handled below). $DB::cmd = 'l ' . ($start) . '+'; + redo CMD; } return; } @@ -3514,10 +3491,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); } @@ -3538,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(); @@ -3556,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; } @@ -3565,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; } @@ -3595,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. @@ -3624,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: @@ -3633,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"; @@ -3643,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; } @@ -3654,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. @@ -3682,8 +3662,6 @@ sub _handle_H_command { unless $hist[$i] =~ /^.?$/; } - $self->i_cmd($i); - next CMD; } @@ -3708,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; } @@ -3799,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. @@ -3808,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; } @@ -3819,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}) { @@ -3834,7 +3814,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)) { @@ -3844,7 +3824,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"); } } @@ -3857,7 +3837,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 ) { @@ -3869,7 +3849,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; } @@ -3899,16 +3879,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; } } @@ -3933,7 +3913,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 $?; @@ -3945,15 +3925,23 @@ 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; } + package DB; # The following code may be executed now: @@ -4043,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] @@ -4085,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) { @@ -4116,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 ) { @@ -4137,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. @@ -4168,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 ) { @@ -4240,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-- ]; @@ -5065,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; @@ -5441,188 +5438,239 @@ later. =cut -sub cmd_l { - my $current_line = $line; - my $cmd = shift; - my $line = shift; +sub _min { + my $min = shift; + foreach my $v (@_) { + if ($v < $min) { + $v = $min; + } + } + return $min; +} - # If this is '-something', delete any spaces after the dash. - $line =~ s/^-\s*$/-/; +sub _minify_to_max { + my $ref = shift; - # If the line is '$something', assume this is a scalar containing a - # line number. - if ( $line =~ /^(\$.*)/s ) { + $$ref = _min($$ref, $max); - # Set up for DB::eval() - evaluate in *user* context. - $evalarg = $1; - # $evalarg = $2; - my ($s) = DB::eval(); + return; +} - # Ooops. Bad scalar. - if ($@) { - print {$OUT} "Error: $@\n"; - next CMD; - } +sub _cmd_l_handle_var_name { + my $var_name = shift; - # 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"; + $evalarg = $var_name; - # Call self recursively to really do the command. - cmd_l( 'l', $s ); - } ## end if ($line =~ /^(\$.*)/s) + my ($s) = DB::eval(); - # l name. Try to find a sub by that name. - elsif ( ($subname) = $line =~ /\A([\':A-Za-z_][\':\w]*(?:\[.*\])?)/s ) { - my $s = $subname; + # 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( 'l', $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 { + my $cmd = shift; + my $line = shift; - # 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. + $line = $subrange; + return cmd_l( 'l', $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( 'l', $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. + my $line = $start . '-' . ( $start + $incr ); + return cmd_l( 'l', $line ); +} + +sub _cmd_l_range { + my ($cmd, $line, $current_line, $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 ); - # Determine end point; use end of file if not specified. - my $end = ( !defined $2 ) ? $max : ( $4 ? $4 : $2 ); + # Go on to the end, and then stop. + _minify_to_max(\$end); - # Go on to the end, and then stop. - $end = $max if $end > $max; + # Determine start line. + my $i = $start_match; + $i = $line if $i eq '.'; + $i = 1 if $i < 1; + $incr = $end - $i; - # Determine start line. - my $i = $2; - $i = $line if $i eq '.'; - $i = 1 if $i < 1; - $incr = $end - $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; + } - # 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 ? ':' : ' ' ); + + # Add break and action indicators. + $arrow .= 'b' if $stop; + $arrow .= 'a' if $action; + + # 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++ ) { - - # Check for breakpoints and actions. - my ( $stop, $action ); - ( $stop, $action ) = split( /\0/, $dbline{$i} ) - if $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 ? ':' : ' ' ); - - # Add break and action indicators. - $arrow .= 'b' if $stop; - $arrow .= 'a' if $action; - - # 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\$\.]+))?)?/) + # 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; +} + +sub cmd_l { + my $current_line = $line; + my $cmd = shift; + my $line = shift; + + # If this is '-something', delete any spaces after the dash. + $line =~ s/\A-\s*\z/-/; + + # 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) = $line =~ /\A(\$.*)/s ) { + return _cmd_l_handle_var_name($var_name); + } + # l name. Try to find a sub by that name. + elsif ( ($subname) = $line =~ /\A([\':A-Za-z_][\':\w]*(?:\[.*\])?)/s ) { + return _cmd_l_handle_subname($cmd, $line); + } + # Bare 'l' command. + elsif ( $line !~ /\S/ ) { + return _cmd_l_empty(); + } + # l [start]+number_of_lines + elsif ( my ($new_start, $new_incr) = $line =~ /\A(\d*)\+(\d*)\z/ ) { + return _cmd_l_plus($new_start, $new_incr); + } + # l start-stop or l start,stop + elsif (my ($s, $e) = $line =~ /^(?:(-?[\d\$\.]+)(?:[-,]([\d\$\.]+))?)?/ ) { + return _cmd_l_range($cmd, $line, $current_line, $s, $e); + } + + return; } ## end sub cmd_l =head3 C - list breakpoints, actions, and watch expressions (command) @@ -5646,7 +5694,10 @@ sub cmd_L { # 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; @@ -5777,13 +5828,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 @@ -6092,7 +6143,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; @@ -6197,7 +6250,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. @@ -6491,7 +6544,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. @@ -6536,43 +6589,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" : "" ), @@ -6584,6 +6637,8 @@ sub system { } ## end sub system +*system = \&_db_system; + =head1 TTY MANAGEMENT The subs here do some of the terminal management for multiple debuggers. @@ -6670,7 +6725,7 @@ sub setterm { $term->MinLine(2); - &load_hist(); + load_hist(); if ( $term->Features->{setHistory} and "@hist" ne "?" ) { $term->SetHistory(@hist); @@ -6933,7 +6988,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 @@ -7419,13 +7474,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 @@ -7447,7 +7504,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. @@ -7512,7 +7569,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 @_; @@ -7531,7 +7590,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; @@ -7548,7 +7607,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; @@ -7564,7 +7623,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; @@ -7597,7 +7656,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 @_; @@ -7606,7 +7665,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 @_; @@ -7663,17 +7722,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 @@ -7693,10 +7759,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 @@ -7720,9 +7786,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); } @@ -8318,7 +8386,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. @@ -8377,7 +8445,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 @@ -8399,12 +8467,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 ) { @@ -8718,7 +8783,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 @@ -8746,7 +8811,6 @@ my %_is_in_pods = (map { $_ => 1 } apio api artistic - beos book boot bot @@ -8771,7 +8835,6 @@ my %_is_in_pods = (map { $_ => 1 } dsc ebcdic embed - epoc faq1 faq2 faq3 @@ -8861,14 +8924,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; } @@ -9557,9 +9620,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; } @@ -9800,7 +9863,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(); @@ -9894,7 +9957,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 [] @@ -9927,13 +9990,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 @@ -10112,7 +10175,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