$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
-# We need the & here because we want to override the prototype.
-&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
%alias,
$doret,
$end,
+ $fall_off_end,
$incr,
$laststep,
$rc,
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;
+}
sub DB {
=cut
- if ($cmd eq 'q') {
- $fall_off_end = 1;
- clean_ENV();
- exit $?;
- }
+ $obj->_handle_q_command;
=head4 C<t> - trace [n]
=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;
- }
- }
+ $obj->_handle_x_command;
=head4 C<m> - print methods
=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
- }
+ _DB__handle_m_command($obj);
=head4 C<f> - switch files
=cut
- _DB__handle_f_command();
+ _DB__handle_f_command($obj);
=head4 C<.> - return to last-executed line.
=cut
- _DB__handle_dot_command($obj);
+ _DB__handle_dot_command($obj);
=head4 C<-> - back one window
# 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;
- }
+ $obj->_handle_cmd_wrapper_commands;
=head4 C<y> - List lexicals in higher scope
=cut
- $obj->_handle_sh_sh_command;
+ $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.
- DB::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
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
return;
}
-sub _handle_sh_sh_command {
+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.
- if (my ($arg) = $DB::cmd =~ m#\A$sh$sh\s*(.*)#ms) {
+ my $my_cmd = $DB::cmd;
+ if ($my_cmd =~ m#\A$sh#gms) {
- # System it.
- DB::system($arg);
- next CMD;
+ 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|[<>\{]{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