considered to be a breakpoint; C<perl5db.pl> 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 C<eval>ed strings looks
like C<(eval 34).
$ini_warn
$maxtrace
$od
- $onetimedumpDepth
@options
$osingle
$otrace
$ImmediateStop,
$line,
$onetimeDump,
+ $onetimedumpDepth,
%option,
$OUT,
$packname,
lock($DBGR);
print "Threads support enabled\n";
} else {
- *lock = sub(*) {};
- *share = sub(*) {};
+ *share = sub(\[$@%]) {};
}
}
}
# 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.
use vars qw(
$action
$cmd
- $fall_off_end
$file
$filename_ini
$finished
$level
$max
$package
- $sh
$try
);
%alias,
$doret,
$end,
+ $fall_off_end,
$incr,
$laststep,
$rc,
+ $sh,
$stack_depth,
@stack,
@to_watch,
}
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
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...
# 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.
# 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.
# 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;
}
return;
}
+sub _DB__handle_restart_and_rerun_commands {
+ my ($obj) = @_;
+
+ # 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) 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" ) || &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" ) || &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);
+
+ 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
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(
{
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,
},
);
#
# 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))
# 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
=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.
# 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
=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<t> - 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<S> - 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<X> - list variables in current package
Since the C<V> command actually processes this, just change this to the
Uses C<dumpvar.pl> to dump out the current values for selected variables.
-=cut
-
- $obj->_handle_V_command_and_X_command;
-
=head4 C<x> - evaluate and print an expression
Hands the expression off to C<DB::eval>, setting it up to print the value
via C<dumpvar.pl> 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<m> - print methods
Just uses C<DB::methods> 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<f> - 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,
currently-executing line, and then put a C<l $start +> (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<a, A, b, B, h, l, L, M, o, O, P, v, w, W, E<lt>, E<lt>E<lt>, E<0x7B>, E<0x7B>E<0x7B>>
In Perl 5.8.0, a realignment of the commands was done to fix up a number of
them. At this point, we check for the new commands and call C<cmd_wrapper> 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<y> - List lexicals in higher scope
Uses C<PadWalker> to find the lexicals supplied as arguments in a scope
above the current one and then displays then using C<dumpvar.pl>.
-=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
when entered (see C<DB::sub>). We also save the C<n> command in C<$laststep>,
so a null command knows what to re-execute.
-=cut
-
- # n - next
- $obj->_handle_n_command;
-
=head4 C<s> - single-step, entering subs
Sets C<$single> to 1, which causes C<DB::sub> to continue tracing inside
subs. Also saves C<s> as C<$lastcmd>.
-=cut
-
- $obj->_handle_s_command;
-
=head4 C<c> - run continuously, setting an optional breakpoint
Most of the code for this command is taken up with locating the optional
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<r> - return from a subroutine
For C<r> to work properly, the debugger has to stop execution again
we are printing return values when a C<r> 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<T> - stack trace
Just calls C<DB::print_trace>.
-=cut
-
- $obj->_handle_T_command;
-
=head4 C<w> - List window around current line.
Just calls C<DB::cmd_w>.
-=cut
-
- $obj->_handle_w_command;
-
=head4 C<W> - watch-expression processing.
Just calls C<DB::cmd_W>.
-=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
=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<pattern> $rc> - Search command history
=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<command>> - Force execution of a command in a shell
Like the above, but the command is passed to the shell. Again, we use
C<DB::system> to avoid problems with C<STDIN> and C<STDOUT>.
-=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;
- }
-
=head4 C<H> - display commands in history
Prints the contents of C<@hist> (if any).
-=cut
-
- $obj->_handle_H_command;
-
=head4 C<man, doc, perldoc> - look up documentation
Just calls C<runman()> to print the appropriate document.
Builds a C<print EXPR> 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<source> - read commands from a file.
Opens a lexical filehandle and stacks it on C<@cmdfhs>; C<DB::readline> will
pick it up.
-=cut
-
- $obj->_handle_source_command;
+=head4 C<enable> C<disable> - enable or disable breakpoints
- if (my ($which_cmd, $position)
- = $cmd =~ /^(enable|disable)\s+(\S+)\s*$/) {
-
- my ($fn, $line_num);
- if ($position =~ m{\A\d+\z})
- {
- $fn = $filename;
- $line_num = $position;
- }
- elsif (my ($new_fn, $new_line_num)
- = $position =~ m{\A(.*):(\d+)\z}) {
- ($fn, $line_num) = ($new_fn, $new_line_num);
- }
- else
- {
- &warn("Wrong spec for enable/disable argument.\n");
- }
-
- if (defined($fn)) {
- if (_has_breakpoint_data_ref($fn, $line_num)) {
- _set_breakpoint_enabled_status($fn, $line_num,
- ($which_cmd eq 'enable' ? 1 : '')
- );
- }
- else {
- &warn("No breakpoint set at ${fn}:${line_num}\n");
- }
- }
-
- next CMD;
- }
+This enables or disables breakpoints.
=head4 C<save> - send current history to a file
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
- if (my ($new_fn) = $cmd =~ /\Asave\s*(.*)\z/) {
- 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/^\s*(save|source)/ ? "#$_" : $_ }
- @truehist );
- print $fh join( "\n", @truelist );
- print "commands saved in $file\n";
- }
- else {
- &warn("Can't save debugger commands in '$new_fn': $!\n");
- }
- next CMD;
- }
-
=head4 C<R> - restart
Restart the debugger session.
Return to any given position in the B<true>-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<OUT> (the debugger's output filehandle) and C<STDOUT>
=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
=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:
# Make sure the flag that says "the debugger's running" is
=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
{
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 {
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;
# Generate and execute a "l +" command (handled below).
$DB::cmd = 'l ' . ($start) . '+';
+ redo CMD;
}
return;
}
if ($DB::cmd eq $letter) {
$self->_n_or_s_commands_generic($new_val);
}
+ else {
+ $self->_n_or_s_and_arg_commands_generic($letter, $new_val);
+ }
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;
}
# 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.
# 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:
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";
}
# 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;
}
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.
unless $hist[$i] =~ /^.?$/;
}
- $self->i_cmd($i);
-
next CMD;
}
if ($DB::cmd eq '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;
}
return;
}
+sub _handle_enable_disable_commands {
+ my $self = shift;
+
+ if (my ($which_cmd, $position)
+ = $DB::cmd =~ /\A(enable|disable)\s+(\S+)\s*\z/) {
+
+ my ($fn, $line_num);
+ if ($position =~ m{\A\d+\z})
+ {
+ $fn = $DB::filename;
+ $line_num = $position;
+ }
+ elsif (my ($new_fn, $new_line_num)
+ = $position =~ m{\A(.*):(\d+)\z}) {
+ ($fn, $line_num) = ($new_fn, $new_line_num);
+ }
+ else
+ {
+ 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::warn("No breakpoint set at ${fn}:${line_num}\n");
+ }
+ }
+
+ next CMD;
+ }
+
+ return;
+}
+
+sub _handle_save_command {
+ my $self = shift;
+
+ if (my ($new_fn) = $DB::cmd =~ /\Asave\s*(.*)\z/) {
+ 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::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::system( $ENV{SHELL} || "/bin/sh" );
+ next CMD;
+ }
+ elsif ($my_cmd =~ m#\G$sh\s*(.*)#cgms) {
+ # System it.
+ DB::system($1);
+ next CMD;
+ }
+ elsif ($my_cmd =~ m#\G\s*(.*)#cgms) {
+ DB::system( $ENV{SHELL} || "/bin/sh", "-c", $1 );
+ next CMD;
+ }
+ }
+}
+
+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;
+ }
+ }
+
+ return;
+}
+
+sub _handle_q_command {
+ my $self = shift;
+
+ if ($DB::cmd eq 'q') {
+ $fall_off_end = 1;
+ DB::clean_ENV();
+ exit $?;
+ }
+
+ return;
+}
+
+sub _handle_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)\s*(.*)/so) {
+ DB::cmd_wrapper( $cmd_letter, $my_arg, $line );
+ next CMD;
+ }
+
+ return;
+}
+
+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;
+ }
+
+ return;
+}
+
package DB;
# The following code may be executed now:
# 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 );
https://perl5.git.perl.org / perl5.git / blobdiff